diff options
Diffstat (limited to 'Lisp')
| -rw-r--r-- | Lisp/data-types.lisp | 7 | ||||
| -rw-r--r-- | Lisp/libobjcl.lisp | 35 | ||||
| -rw-r--r-- | Lisp/method-invocation.lisp | 5 | ||||
| -rw-r--r-- | Lisp/utilities.lisp | 33 |
4 files changed, 66 insertions, 14 deletions
diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp index 533578b..7b07624 100644 --- a/Lisp/data-types.lisp +++ b/Lisp/data-types.lisp @@ -108,6 +108,13 @@ a suitable class method instead as you would in Objective C. (:documentation "")) +(defclass objc-meta-class (c-pointer-wrapper) + ((meta-class-for-class :type (or null id objc-class) + :initarg :meta-class-for-class + :reader meta-class-for-class)) + (:documentation "")) + + (define-condition exception (error) ((pointer :type c-pointer :accessor pointer-to diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp index ffe166f..fd7caca 100644 --- a/Lisp/libobjcl.lisp +++ b/Lisp/libobjcl.lisp @@ -57,6 +57,20 @@ (object obj-data) (selector obj-data)) +(defcfun ("objcl_object_is_class" %objcl-object-is-class) :boolean + (obj :pointer)) + +(defcfun ("objcl_object_is_meta_class" %objcl-object-is-meta-class) + :boolean + (obj :pointer)) + +(defcfun ("objcl_object_get_class" %objcl-object-get-class) :pointer + (obj :pointer)) + +(defcfun ("objcl_object_get_meta_class" %objcl-object-get-meta-class) + :pointer + (obj :pointer)) + (defun initialise-runtime () "Initialise the Objective C runtime. @@ -284,6 +298,27 @@ by which __invoke__ converts its arguments into a *message name*. selector-name))))) +(defun object-is-class-p (obj) + (%objcl-object-is-class (pointer-to obj))) + +(defun object-is-meta-class-p (obj) + (%objcl-object-is-meta-class (pointer-to obj))) + +(defun object-get-class (obj) + (make-instance 'objc-class + :pointer (%objcl-object-get-class (pointer-to obj)))) + +(defun object-get-meta-class (obj) + (make-instance 'objc-meta-class + :pointer (%objcl-object-get-meta-class (pointer-to obj)) + :meta-class-for-class (object-get-class obj))) + +(defun objc-class-of (obj) + (cond ((object-is-meta-class-p obj) + (error "Tried to get the class of meta class ~S." obj)) + ((object-is-class-p obj) (object-get-meta-class obj)) + (t (object-get-class obj)))) + ;;; (@* "Low-level Data Conversion") (eval-when (:compile-toplevel :load-toplevel) ;; In order to be able to dispatch over pointer types, we need to diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp index bc6cc2d..e290e50 100644 --- a/Lisp/method-invocation.lisp +++ b/Lisp/method-invocation.lisp @@ -392,15 +392,14 @@ Returns: *result* --- the return value of the method invocation. (defun invoke-with-conversion (receiver method-name &rest args) (let* ((selector (selector method-name)) - (class (primitive-invoke receiver 'class 'objc-class))) + (class (object-get-class receiver))) (multiple-value-bind (argc method-return-typestring method-return-type method-arg-typestrings method-arg-types) (retrieve-method-signature-info class selector - (if (cffi:pointer-eq (pointer-to receiver) - (pointer-to class)) + (if (object-is-class-p receiver) :class :instance)) (assert (= argc (+ 2 (length args))) diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp index 2e8839c..710ac94 100644 --- a/Lisp/utilities.lisp +++ b/Lisp/utilities.lisp @@ -95,32 +95,43 @@ ;;; (@* "Object Representation") (defmethod print-object ((object id) stream) (print-unreadable-object (object stream) - (format stream "~A `~A' {~X}" - (objcl-class-name (primitive-invoke object "class" 'id)) - (primitive-invoke (primitive-invoke object "description" 'id) - "UTF8String" :string) - (primitive-invoke object "hash" :unsigned-int)))) + (with-slots (pointer) object + (format stream "~A `~A' {~X}" + (objcl-class-name (primitive-invoke object "class" 'id)) + (primitive-invoke (primitive-invoke object "description" 'id) + "UTF8String" :string) + (cffi:pointer-address pointer))))) (defmethod print-object ((class objc-class) stream) (print-unreadable-object (class stream) - (format stream "~S ~A {~X}" - 'objc-class - (objcl-class-name class) - (primitive-invoke class "hash" :unsigned-int)))) + (with-slots (pointer) class + (format stream "~S ~A {~X}" + (type-of class) + (objcl-class-name class) + (cffi:pointer-address pointer))))) + + +(defmethod print-object ((meta-class objc-meta-class) stream) + (print-unreadable-object (meta-class stream) + (with-slots (meta-class-for-class pointer) meta-class + (format stream "~S ~A {~X}" + (type-of meta-class) + (objcl-class-name meta-class-for-class) + (cffi:pointer-address pointer))))) (defmethod print-object ((selector selector) stream) (print-unreadable-object (selector stream) (format stream "~S `~A'" - 'selector + (type-of selector) (selector-name selector)))) (defmethod print-object ((exception exception) stream) (print-unreadable-object (exception stream) (format stream "~S ~A {~X}" - 'exception + (type-of exception) (primitive-invoke (primitive-invoke exception "name" 'id) "UTF8String" :string) (primitive-invoke exception "hash" :unsigned-int)))) |