From 50025d579200f44fa24701bfbb4199f652c1fe52 Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Tue, 18 Sep 2007 17:00:21 +0200 Subject: Simplify the Objective-C layer, make the newest additions compatible with the Apple runtime. darcs-hash:c6ec225e9ccf78e267f1a4985971ec9ac3239bc8 --- Lisp/libobjcl.lisp | 52 ++++++++++--------------- Lisp/method-invocation.lisp | 15 +++----- Lisp/utilities.lisp | 13 ++++--- Objective-C/libobjcl.h | 12 +++--- Objective-C/libobjcl.m | 94 ++++++++++----------------------------------- 5 files changed, 60 insertions(+), 126 deletions(-) diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp index 072eb30..9849392 100644 --- a/Lisp/libobjcl.lisp +++ b/Lisp/libobjcl.lisp @@ -42,20 +42,20 @@ (defcfun ("objcl_find_class" %objcl-find-class) :pointer (class-name :string)) -(defcfun ("objcl_class_name" %objcl-class-name) :pointer - (class obj-data)) +(defcfun ("objcl_class_name" %objcl-class-name) :string + (class :pointer)) (defcfun ("objcl_find_selector" %objcl-find-selector) :pointer (selector-name :string)) -(defcfun ("objcl_selector_name" %objcl-selector-name) :pointer - (selector obj-data)) +(defcfun ("objcl_selector_name" %objcl-selector-name) :string + (selector :pointer)) (defcfun ("objcl_get_method_implementation" %objcl-get-method-implementation) :pointer - (object obj-data) - (selector obj-data)) + (object :pointer) + (selector :pointer)) (defcfun ("objcl_object_is_class" %objcl-object-is-class) :boolean (obj :pointer)) @@ -198,49 +198,43 @@ conventional case for namespace identifiers in Objective C." (declaim (ftype (function (string) (or null objc-class)) find-objc-class-by-name)) (defun find-objc-class-by-name (class-name) - (with-obj-data-values ((obj-data (%objcl-find-class class-name))) - (if (null-pointer-p (foreign-slot-value - (foreign-slot-value obj-data 'obj-data 'data) - 'obj-data-union - 'class-val)) + (let ((class-ptr (%objcl-find-class class-name))) + (if (cffi:null-pointer-p class-ptr) nil - (the objc-class (obj-data->lisp obj-data))))) + #-openmcl (make-instance 'objc-class :pointer class-ptr) + #+openmcl (change-class (make-instance 'c-pointer-wrapper + :pointer value) + 'objc-class)))) (declaim (ftype (function (string) (or null selector)) find-selector-by-name)) (defun find-selector-by-name (selector-name) - (with-obj-data-values ((obj-data (%objcl-find-selector selector-name))) - (if (null-pointer-p (foreign-slot-value - (foreign-slot-value obj-data 'obj-data 'data) - 'obj-data-union - 'sel-val)) + (let ((selector-ptr (%objcl-find-selector selector-name))) + (if (cffi:null-pointer-p selector-ptr) nil - (the selector (obj-data->lisp obj-data))))) + (make-instance 'selector :pointer selector-ptr)))) (declaim (ftype (function ((or objc-class id exception)) string) objcl-class-name)) (defun objcl-class-name (class) (declare (type (or objc-class id exception) class)) - (with-foreign-conversion ((obj-data class)) - (foreign-string-to-lisp/dealloc (%objcl-class-name obj-data)))) + (%objcl-class-name (pointer-to class))) (declaim (ftype (function (selector) string) selector-name)) (defun selector-name (selector) (declare (type selector selector)) - (with-foreign-conversion ((obj-data selector)) - (foreign-string-to-lisp/dealloc (%objcl-selector-name obj-data)))) + (%objcl-selector-name (pointer-to selector))) (declaim (ftype (function ((or id objc-class exception) selector) *) get-method-implementation)) (defun get-method-implementation (object selector) (declare (type selector selector)) - (with-foreign-conversion ((sel-obj-data selector) - (obj-obj-data object)) - (%objcl-get-method-implementation obj-obj-data sel-obj-data))) + (%objcl-get-method-implementation (pointer-to object) + (pointer-to selector))) (declaim (ftype (function ((or selector string list)) (or null selector)) @@ -425,13 +419,7 @@ If *selector-designator* is a __selector__, it is simply returned. (type-name->slot-name type-name))))) (case lisp-type ((id objc-class selector exception) - #-openmcl (make-instance lisp-type :pointer value) - #+openmcl (if (eq 'objc-class lisp-type) - ;; God help me. - (change-class (make-instance 'c-pointer-wrapper - :pointer value) - lisp-type) - (make-instance lisp-type :pointer value))) + (make-instance lisp-type :pointer value) ) ((string) (foreign-string-to-lisp value)) (otherwise value))))) diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp index edbdc17..6176553 100644 --- a/Lisp/method-invocation.lisp +++ b/Lisp/method-invocation.lisp @@ -4,7 +4,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (unless (boundp '+nil+) (defconstant +nil+ - (make-instance 'id :pointer (objcl-get-nil))))) + (make-instance 'id :pointer (objcl-get-nil))))) ;;; (@* "Method invocation") @@ -154,7 +154,8 @@ Returns: *result* --- the return value of the method invocation. (defmacro unsafe-primitive-invoke (receiver method-name return-type &rest args) - (let ((real-return-type (if (member return-type '(id objc-class exception)) + (let ((real-return-type (if (member return-type '(id objc-class exception + selector)) :pointer return-type)) (real-receiver (gensym)) @@ -175,13 +176,10 @@ Returns: *result* --- the return value of the method invocation. (list :pointer (pointer-to ,real-selector)) objc-arglist (list ,real-return-type))))) - ,(if (member return-type '(id objc-class exception)) + ,(if (member return-type '(id objc-class exception selector)) `(let (,@(when (constructor-name-p (selector-name selector)) `((*skip-retaining* t)))) - (make-instance ',(case return-type - ((id) 'id) - ((objc-class) 'objc-class) - ((exception) 'exception)) + (make-instance return-type :pointer return-value)) `return-value)) (dealloc-objc-arglist objc-arglist))))))) @@ -277,8 +275,7 @@ Returns: *result* --- the return value of the method invocation. return-c-type))) (if (cffi:null-pointer-p pointer) nil - (make-instance return-type - :pointer pointer)))) + (make-instance return-type :pointer pointer)))) ((:void) (values)) (otherwise (cffi:mem-ref return-value-cell return-c-type))))))))))) diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp index a81b61c..b44c05d 100644 --- a/Lisp/utilities.lisp +++ b/Lisp/utilities.lisp @@ -6,8 +6,9 @@ (defun truep (b) - (not (or (zerop b) - (null b)))) + (or (eq b t) + (and (numberp b) + (not (zerop b))))) (defun id-eql (x y) @@ -16,17 +17,17 @@ (defun id-equal (x y) (truep (if (typep x '(or id objc-class exception)) - (invoke x :is-equal y) + (primitive-invoke x :is-equal :boolean y) (progn (assert (typep y '(or id objc-class exception))) - (invoke y :is-equal x))))) + (primitive-invoke y :is-equal :boolean x))))) (defun objc-typep (x class-designator) - (objc-eql (invoke x 'class) + (objc-eql (object-get-class x) (etypecase x (class x) - (id (invoke x 'class)) + (id (object-get-class x)) ((or string symbol) (find-objc-class class-designator t))))) diff --git a/Objective-C/libobjcl.h b/Objective-C/libobjcl.h index 9c673f7..a912748 100644 --- a/Objective-C/libobjcl.h +++ b/Objective-C/libobjcl.h @@ -57,10 +57,10 @@ objcl_invoke_with_types (int argc, void *return_value, void **argv); -OBJCL_OBJ_DATA +Class objcl_find_class (const char *class_name); -OBJCL_OBJ_DATA +SEL objcl_find_selector (const char *selector_name); /* Return a null-terminated list of type information strings. @@ -71,14 +71,14 @@ objcl_query_arglist_info (void *receiver, const char * -objcl_class_name (OBJCL_OBJ_DATA class); +objcl_class_name (Class class); const char * -objcl_selector_name (OBJCL_OBJ_DATA class); +objcl_selector_name (SEL selector); IMP -objcl_get_method_implementation (OBJCL_OBJ_DATA object, - OBJCL_OBJ_DATA selector); +objcl_get_method_implementation (id object, + SEL selector); BOOL objcl_object_is_class (id obj); diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m index 1a17a44..eaffb8c 100644 --- a/Objective-C/libobjcl.m +++ b/Objective-C/libobjcl.m @@ -336,61 +336,27 @@ objcl_invoke_with_types (int argc, #endif -OBJCL_OBJ_DATA +Class objcl_find_class (const char *class_name) { - Class class = - NSClassFromString ([NSString stringWithUTF8String: class_name]); - OBJCL_OBJ_DATA result = malloc (sizeof (struct objcl_object)); - const char *const typespec = @encode (Class); - - result->type = malloc (strlen (typespec) + 1); - strcpy (result->type, typespec); - result->data.class_val = class; - - return result; + return NSClassFromString ([NSString stringWithUTF8String: class_name]); } -OBJCL_OBJ_DATA +SEL objcl_find_selector (const char *class_name) { - SEL selector = - NSSelectorFromString ([NSString stringWithUTF8String: class_name]); - OBJCL_OBJ_DATA result = malloc (sizeof (struct objcl_object)); - const char *const typespec = @encode (SEL); - - result->type = malloc (strlen (typespec) + 1); - strcpy (result->type, typespec); - result->data.sel_val = selector; - - return result; + return NSSelectorFromString ([NSString stringWithUTF8String: class_name]); } const char * -objcl_class_name (OBJCL_OBJ_DATA class) +objcl_class_name (Class class) { const char *ns_name; char *name; - Class cls = NULL; - switch (class->type[0]) - { - case '#': - cls = class->data.class_val; - break; - case '@': - cls = class->data.id_val; - break; - case 'E': - cls = (id) class->data.exc_val; - break; - default: - return NULL; - } - - ns_name = [(NSStringFromClass (cls)) UTF8String]; + ns_name = [(NSStringFromClass (class)) UTF8String]; name = malloc (strlen (ns_name) + 1); strcpy (name, ns_name); @@ -399,16 +365,12 @@ objcl_class_name (OBJCL_OBJ_DATA class) const char * -objcl_selector_name (OBJCL_OBJ_DATA selector) +objcl_selector_name (SEL selector) { const char *ns_name; char *name; - if (strcmp (selector->type, @encode (SEL)) != 0) - return NULL; - - ns_name = [(NSStringFromSelector (selector->data.sel_val)) - UTF8String]; + ns_name = [(NSStringFromSelector (selector)) UTF8String]; name = malloc (strlen (ns_name) + 1); strcpy (name, ns_name); @@ -417,34 +379,20 @@ objcl_selector_name (OBJCL_OBJ_DATA selector) IMP -objcl_get_method_implementation (OBJCL_OBJ_DATA object, - OBJCL_OBJ_DATA selector) +objcl_get_method_implementation (id object, + SEL selector) { - id obj; - - if (strcmp (selector->type, @encode (SEL)) != 0) - return NULL; - - switch (object->type[0]) +#ifdef __NEXT_RUNTIME__ + if (objcl_object_is_class (object)) { - case '#': - obj = object->data.class_val; - break; - case '@': - obj = object->data.id_val; - break; - case 'E': - obj = (id) object->data.exc_val; - break; - default: - return NULL; + return class_getClassMethod (object, selector)->method_imp; + } + else + { + return class_getInstanceMethod ([object class], selector)->method_imp; } - -#ifdef __NEXT_RUNTIME__ - return class_getInstanceMethod ([obj class], - selector->data.sel_val)->method_imp; #else - return objc_msg_lookup (obj, selector->data.sel_val); + return objc_msg_lookup (object, selector); #endif } @@ -453,7 +401,7 @@ BOOL objcl_object_is_class (id obj) { #ifdef __NEXT_RUNTIME__ - return [obj class] == obj + return [obj class] == obj; #else /* return CLS_ISCLASS (obj); */ return object_is_class (obj); @@ -466,7 +414,7 @@ objcl_object_is_meta_class (id obj) { #ifdef __NEXT_RUNTIME__ /* FIXME: What to do here? */ - return [[obj class] metaClass] == obj; + return objcl_object_get_meta_class (obj) == obj; #else /* return CLS_ISMETA (ptr); */ if (objcl_object_is_class (obj)) @@ -494,7 +442,7 @@ objcl_object_get_meta_class (id obj) { #ifdef __NEXT_RUNTIME__ /* FIXME: What to do here? */ - return [[obj class] metaClass]; + return objc_getMetaClass ([(NSStringFromClass ([obj class])) UTF8String]); #else if (objcl_object_is_class (obj)) return class_get_meta_class (obj); -- cgit v1.2.3