Reimplement PRIMITIVE-INVOKE and rename the old version UNSAFE-PRIMITIVE-INVOKE.

darcs-hash:a941bade2677db3d5773c20ffda171c7c9721a98

7 files changed, 107 insertions, 18 deletions

diff --git a/Lisp/constant-data.lisp b/Lisp/constant-data.lisp
index 29169de..efda456 100644
--- a/Lisp/constant-data.lisp
+++ b/Lisp/constant-data.lisp
@@ -108,6 +108,10 @@
                       (typep value type))
                   *objcl-type-map*)))
 
+(declaim (ftype (function (symbol) symbol) lisp-type->type-name))
+(defun lisp-type->type-name (lisp-type)
+  (cdr (rassoc lisp-type *objcl-type-map*)))
+
 (declaim (ftype (function (symbol) symbol) type-name->lisp-type))
 (defun type-name->lisp-type (type-name)
   (cdr (assoc type-name *objcl-type-map*)))
diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp
index 6f66e8c..c757070 100644
--- a/Lisp/data-types.lisp
+++ b/Lisp/data-types.lisp
@@ -42,7 +42,7 @@
   ((pointer :type     c-pointer
             :reader   pointer-to
             :initarg  :pointer
-            :initform nil)))
+            :initform (cffi:null-pointer))))
 
 
 (defclass selector   (c-pointer-wrapper) ()
diff --git a/Lisp/defpackage.lisp b/Lisp/defpackage.lisp
index c6d65a0..46114d5 100644
--- a/Lisp/defpackage.lisp
+++ b/Lisp/defpackage.lisp
@@ -1,6 +1,7 @@
 (defpackage #:mulk.objective-cl
   (:nicknames #:objcl #:objective-cl #:mulk.objcl)
   (:use #:cl #:cffi #:split-sequence)
+  (:shadow #:foreign-pointer)
 
            ;; Functions
   (:export #:initialise-runtime
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index d5d7379..d1efe53 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -32,6 +32,15 @@
   (argc :int)
   &rest)
 
+(defcfun ("objcl_invoke_with_types" %objcl-invoke-with-types) :pointer
+  (receiver (:pointer :void))
+  (method_selector (:pointer :void))
+  (argc :int)
+  (return_typespec (:pointer :char))
+  (arg_typespecs (:pointer (:pointer :char)))
+  (return_value (:pointer :void))
+  (argv (:pointer (:pointer :void))))
+
 (defcfun ("objcl_find_class" %objcl-find-class) :pointer
   (class-name :string))
 
@@ -175,7 +184,7 @@ 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-foreign-objects ((obj-data (%objcl-find-class 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
@@ -187,7 +196,7 @@ conventional case for namespace identifiers in Objective C."
 (declaim (ftype (function (string) (or null selector))
                 find-selector-by-name))
 (defun find-selector-by-name (selector-name)
-  (with-foreign-objects ((obj-data (%objcl-find-selector 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
@@ -285,9 +294,10 @@ by which __invoke__ converts its arguments into a *message name*.
   ;; to use CHECK-TYPE in the method body.
   (unless (find-class 'foreign-pointer nil)
     (setf (find-class 'foreign-pointer nil)
-          (class-of (make-pointer 0))))
-  (deftype foreign-pointer ()
-    '(satisfies cffi:pointerp)))
+          (class-of (make-pointer 0)))
+    (ignore-errors
+      (deftype foreign-pointer ()
+        '(satisfies cffi:pointerp)))))
 
 
 (declaim (ftype (function ((or selector string symbol list)) selector)
@@ -380,7 +390,13 @@ If *selector-designator* is a __selector__, it is simply returned.
                                               (type-name->slot-name type-name)))))
       (case lisp-type
         ((id objc-class selector exception)
-         (make-instance lisp-type :pointer value))
+         #-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)))
         ((string) (foreign-string-to-lisp value))
         (otherwise value)))))
 
diff --git a/Lisp/memory-management.lisp b/Lisp/memory-management.lisp
index 4dec98e..849e9d0 100644
--- a/Lisp/memory-management.lisp
+++ b/Lisp/memory-management.lisp
@@ -30,7 +30,7 @@
                            :incomplete)
                      (let ((new-obj (call-next-method)))
                        (unless *skip-retaining*
-                         (primitive-invoke new-obj "retain" :id))
+                         (unsafe-primitive-invoke new-obj "retain" id))
                        (unless *skip-finalization*
                          ;; We only put the new object into the hash
                          ;; table if it is a regular wrapper object
@@ -56,7 +56,7 @@
                                                       (*skip-retaining*    t))
                                                   (make-instance saved-type
                                                                  :pointer saved-pointer))))
-                                      (primitive-invoke temp "release" :id))))
+                                      (unsafe-primitive-invoke temp "release" id))))
                              (trivial-garbage:finalize new-obj #'finalizer))))
                        new-obj))
                (t obj))))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 9d5eada..43a3365 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -147,8 +147,8 @@ Returns: *result* --- the return value of the method invocation.
         (dealloc-objc-arglist objc-arglist)))))
 
 
-(defmacro primitive-invoke (receiver method-name return-type &rest args)
-  (let ((real-return-type (if (member return-type '(:id :class :exception))
+(defmacro unsafe-primitive-invoke (receiver method-name return-type &rest args)
+  (let ((real-return-type (if (member return-type '(id class exception))
                               :pointer
                               return-type))
         (real-receiver (gensym))
@@ -169,18 +169,86 @@ 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 :class :exception))
+                 ,(if (member return-type '(id class exception))
                       `(let (,@(when (constructor-name-p (selector-name selector))
                                  `((*skip-retaining* t))))
                          (make-instance ',(case return-type
-                                            ((:id) 'id)
-                                            ((:class) 'objc-class)
-                                            ((:exception) 'exception))
+                                            ((id) 'id)
+                                            ((class) 'objc-class)
+                                            ((exception) 'exception))
                             :pointer return-value))
                       `return-value))
              (dealloc-objc-arglist objc-arglist)))))))
 
 
+(defun primitive-invoke (receiver method-name return-type &rest args)
+  (let ((return-c-type (case return-type
+                         ((id class exception selector) :pointer)
+                         (otherwise return-type)))
+        (return-type-cell (cffi:foreign-string-alloc
+                           (type-name->type-id return-type)))
+        (selector (selector method-name)))
+    (cffi:with-foreign-objects ((arg-types '(:pointer :char) (length args))
+                                (objc-args '(:pointer :void) (length args))
+                                (return-value-cell return-c-type))
+      (flet ((ad-hoc-arglist->objc-arglist! (args)
+               (loop for arg in args
+                     for i from 0
+                     do (let* ((type-name (lisp-value->type-name arg))
+                               #+(or)
+                               (cffi-type (type-name->lisp-type type-name)))
+                          (setf (cffi:mem-aref objc-args '(:pointer :void) i)
+                                (typecase arg
+                                  #+(or)
+                                  (c-pointer
+                                   ;; Assume that arg points to a struct,
+                                   ;; and that the method wants a copy of
+                                   ;; that struct, not the pointer itself.
+                                   arg)
+                                  (t (cffi:foreign-alloc
+                                      #+(or) cffi-type
+                                      :pointer
+                                      :initial-element (typecase arg
+                                                         (c-pointer-wrapper
+                                                          (print (pointer-to arg)))
+                                                         (t arg))))))
+                          (setf (cffi:mem-aref arg-types '(:pointer :char) i)
+                                (cffi:foreign-string-alloc
+                                 (typecase arg
+                                   #+(or) (c-pointer "{?=}")
+                                   (t (type-name->type-id type-name))))))))
+             (dealloc-ad-hoc-objc-arglist ()
+               (dotimes (i (length args))
+                 (cffi:foreign-free
+                  (cffi:mem-aref objc-args '(:pointer :void) i))
+                 (cffi:foreign-string-free
+                  (cffi:mem-aref arg-types '(:pointer :char) i)))))
+        (ad-hoc-arglist->objc-arglist! args)
+        (unwind-protect
+            (let ((error-cell
+                   (%objcl-invoke-with-types (pointer-to receiver)
+                                             (pointer-to selector)
+                                             (length args)
+                                             return-type-cell
+                                             arg-types
+                                             return-value-cell
+                                             objc-args)))
+              (unless (cffi:null-pointer-p error-cell)
+                (error (make-instance 'exception :pointer error-cell)))
+              (case return-type
+                ((id class exception selector)
+                 (let ((*skip-retaining*
+                        (or *skip-retaining*
+                            (constructor-name-p (selector-name selector)))))
+                   (make-instance return-type
+                      :pointer (cffi:mem-ref return-value-cell
+                                             return-c-type))))
+                (otherwise (cffi:mem-ref return-value-cell
+                                         return-c-type))))
+          (dealloc-ad-hoc-objc-arglist)
+          (foreign-string-free return-type-cell))))))
+
+
 ;;; (@* "Helper functions")
 (defun arglist->objc-arglist (arglist)
   (arglist-intersperse-types (mapcar #'lisp->obj-data arglist)))
diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp
index be6f8b4..405cacf 100644
--- a/Lisp/utilities.lisp
+++ b/Lisp/utilities.lisp
@@ -96,8 +96,8 @@
 (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)
+            (objcl-class-name (primitive-invoke object "class" 'id))
+            (primitive-invoke (primitive-invoke object "description" 'id)
                               "UTF8String" :string)
             (primitive-invoke object "hash" :unsigned-int))))
 
@@ -121,6 +121,6 @@
   (print-unreadable-object (exception stream)
     (format stream "~S ~A {~X}"
             'exception
-            (primitive-invoke (primitive-invoke exception "name" :id)
+            (primitive-invoke (primitive-invoke exception "name" 'id)
                               "UTF8String" :string)
             (primitive-invoke exception "hash" :unsigned-int))))