diff options
| -rw-r--r-- | Lisp/class-definition.lisp | 20 | ||||
| -rw-r--r-- | Lisp/data-types.lisp | 7 | ||||
| -rw-r--r-- | Lisp/libobjcl.lisp | 19 | ||||
| -rw-r--r-- | Lisp/memory-management.lisp | 15 | ||||
| -rw-r--r-- | Lisp/name-conversion.lisp | 8 | ||||
| -rw-r--r-- | Lisp/utilities.lisp | 6 |
6 files changed, 51 insertions, 24 deletions
diff --git a/Lisp/class-definition.lisp b/Lisp/class-definition.lisp index ea77362..75481d0 100644 --- a/Lisp/class-definition.lisp +++ b/Lisp/class-definition.lisp @@ -119,6 +119,26 @@ wrapped-foreign-class) (call-next-method)) +(defmethod initialize-instance ((class objective-c-meta-class) + &key documentation + name + plist + direct-superclasses + direct-slots + direct-default-initargs + pointer) + (call-next-method)) + +(defmethod reinitialize-instance ((class objective-c-meta-class) + &key documentation + name + plist + direct-superclasses + direct-slots + direct-default-initargs + pointer) + (call-next-method)) + #+(or) (defmethod c2mop:compute-effective-slot-definition ((class objective-c-class) slot-name diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp index 1f33af6..6c696f4 100644 --- a/Lisp/data-types.lisp +++ b/Lisp/data-types.lisp @@ -93,11 +93,8 @@ a suitable class method instead as you would in Objective-C. ()) -(defclass objc-meta-class (c-pointer-wrapper) - ((meta-class-for-class :type (or null id objective-c-class) - :initarg :meta-class-for-class - :reader meta-class-for-class)) - (:documentation "")) +(defclass objective-c-meta-class (standard-class c-pointer-wrapper) + ()) (define-condition exception (error) diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp index dd4ec88..40c41ec 100644 --- a/Lisp/libobjcl.lisp +++ b/Lisp/libobjcl.lisp @@ -250,14 +250,16 @@ conventional case for namespace identifiers in Objective-C." nil)))) -(defun find-objc-meta-class-by-name (class-name) - (let ((class-ptr (%objcl-find-meta-class class-name))) +(defun find-objc-meta-class-by-name (class-name-string) + (let ((class-ptr (%objcl-find-meta-class class-name-string))) (if (objc-pointer-null class-ptr) nil - #-(or t openmcl) (make-pointer-wrapper 'objc-meta-class :pointer class-ptr) - #+(and nil openmcl) (change-class (make-pointer-wrapper 'c-pointer-wrapper - :pointer value) - 'objc-meta-class)))) + (let ((class-name (objc-meta-class-name->symbol class-name-string))) + (or (find-class class-name nil) + (c2mop:ensure-class class-name + :metaclass 'objective-c-meta-class + :pointer class-ptr)))))) + (defun objc-pointer-null (pointer) (or (cffi:null-pointer-p pointer) @@ -569,9 +571,8 @@ separating parts by hyphens works nicely in all of the `:INVERT`, (%objcl-class-name (%objcl-object-get-class (pointer-to obj))))) (defun object-get-meta-class (obj) - (make-pointer-wrapper 'objc-meta-class - :pointer (%objcl-object-get-meta-class (pointer-to obj)) - :meta-class-for-class (object-get-class obj))) + (find-objc-meta-class-by-name + (%objcl-class-name (%objcl-object-get-class (pointer-to obj))))) (defun objc-class-of (obj) (cond ((object-is-meta-class-p obj) diff --git a/Lisp/memory-management.lisp b/Lisp/memory-management.lisp index 4b6666e..5463e0b 100644 --- a/Lisp/memory-management.lisp +++ b/Lisp/memory-management.lisp @@ -21,19 +21,20 @@ (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 *meta-class-objects* (make-weak-value-hash-table)) (defun make-pointer-wrapper (class &rest initargs &key pointer &allow-other-keys) - (when (and (not (eq 'selector class)) - (%objcl-object-is-class pointer)) - (return-from make-pointer-wrapper - (find-objc-class-by-name (%objcl-class-name pointer)))) + (when (not (eq 'selector class)) + (cond ((%objcl-object-is-meta-class pointer) + (return-from make-pointer-wrapper + (find-objc-meta-class-by-name (%objcl-class-name pointer)))) + ((%objcl-object-is-class pointer) + (return-from make-pointer-wrapper + (find-objc-class-by-name (%objcl-class-name pointer)))))) (let* ((hash-table (ecase class ((id) *id-objects*) ((exception) *exception-objects*) - ((selector) *selector-objects*) - ((objc-meta-class) *meta-class-objects*))) + ((selector) *selector-objects*))) (address (cffi:pointer-address pointer)) (object (weak-gethash address hash-table nil)) (constructor (case class diff --git a/Lisp/name-conversion.lisp b/Lisp/name-conversion.lisp index 64a42c7..9b27e70 100644 --- a/Lisp/name-conversion.lisp +++ b/Lisp/name-conversion.lisp @@ -99,3 +99,11 @@ ;; of (READTABLE-CASE *READTABLE*), which means that 'ns-object ;; should always mean the same thing as "NSObject". (read-from-string class-name))) + + +(defun objc-meta-class-name->symbol (meta-class-name) + (let ((*package* (find-package '#:objective-c-classes))) + (read-from-string + (concatenate 'string + "%" + (symbol-name (objc-class-name->symbol meta-class-name)))))) diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp index ef658f2..ccf80cf 100644 --- a/Lisp/utilities.lisp +++ b/Lisp/utilities.lisp @@ -257,12 +257,12 @@ invocations will return numbers.) (cffi:pointer-address pointer))))) -(defmethod print-object ((meta-class objc-meta-class) stream) +(defmethod print-object ((meta-class objective-c-meta-class) stream) (print-unreadable-object (meta-class stream) - (with-slots (meta-class-for-class pointer) meta-class + (with-slots (pointer) meta-class (format stream "~S ~A {~X}" (type-of meta-class) - (objc-class-name meta-class-for-class) + (class-name meta-class) (cffi:pointer-address pointer))))) |