Simplify the Objective-C layer, make the newest additions compatible with the Apple runtime.

darcs-hash:c6ec225e9ccf78e267f1a4985971ec9ac3239bc8

3 files changed, 33 insertions, 47 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)))))