diff options
| author | Matthias Benkard <code@mail.matthias.benkard.de> | 2008-03-19 03:20:52 +0100 |
|---|---|---|
| committer | Matthias Benkard <code@mail.matthias.benkard.de> | 2008-03-19 03:20:52 +0100 |
| commit | f9180cd67505f16a8588a83da82f263bc395b347 (patch) | |
| tree | 35410836910cdaf784f728e09509fb00c2365ed6 /Lisp | |
| parent | e63bff30be008c4dfe1ee225c1879baecbeb0ab3 (diff) | |
Make INTERN-POINTER-WRAPPER intern OBJECTIVE-C-CLASSes.
darcs-hash:8ea30cedc918a1d45612a6efb68126715c2cf8ef
Diffstat (limited to 'Lisp')
| -rw-r--r-- | Lisp/libobjcl.lisp | 8 | ||||
| -rw-r--r-- | Lisp/memory-management.lisp | 5 |
2 files changed, 9 insertions, 4 deletions
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp index 39b1e2d..38b244f 100644 --- a/Lisp/libobjcl.lisp +++ b/Lisp/libobjcl.lisp @@ -732,9 +732,11 @@ separating parts by hyphens works nicely in all of the `:INVERT`, (defun object-get-class (obj) ;; OPTIMISE: Both find-objc-class-by-name and %objcl-class-name are - ;; slow and mostly unneeded. - (find-objc-class-by-name - (%objcl-class-name (%objcl-object-get-class (pointer obj))))) + ;; slow and mostly unneeded. We can simply retrieve classes by class + ;; pointer if they have already been registered in a hash table + ;; somewhere. + (intern-pointer-wrapper 'objective-c-class + :pointer (%objcl-object-get-class (pointer obj)))) (defun object-get-meta-class (obj) (find-objc-meta-class-by-name diff --git a/Lisp/memory-management.lisp b/Lisp/memory-management.lisp index 890e96f..bca6a84 100644 --- a/Lisp/memory-management.lisp +++ b/Lisp/memory-management.lisp @@ -21,6 +21,7 @@ (defvar *id-objects* (make-weak-value-hash-table)) (defvar *exception-objects* (make-weak-value-hash-table)) (defvar *selector-objects* (make-weak-value-hash-table)) +(defvar *class-objects* (make-hash-table)) (defun intern-pointer-wrapper (class &rest initargs &key pointer &allow-other-keys) @@ -37,7 +38,9 @@ (find-objc-meta-class-by-name (%objcl-class-name pointer)))) ((%objcl-object-is-class pointer) (return-from intern-pointer-wrapper - (find-objc-class-by-name (%objcl-class-name pointer)))) + (or (gethash (pointer-address pointer) *class-objects*) + (setf (gethash (pointer-address pointer) *class-objects*) + (find-objc-class-by-name (%objcl-class-name pointer)))))) ((objcl-object-backed-by-lisp-class-p/pointer pointer) (return-from intern-pointer-wrapper (apply #'intern-lisp-managed-foreign-instance initargs))))) |