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 ++++++------ 3 files changed, 33 insertions(+), 47 deletions(-) (limited to 'Lisp') 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))))) -- cgit v1.2.3