INVOKE-WITH-CONVERSION: Support arrays, structs, and unions, and convert Lisp objects into Objective-C instances automatically.

darcs-hash:decc92c91c315c1e347b9f5327bfb6e21ccca9a8

4 files changed, 85 insertions, 33 deletions

diff --git a/Lisp/defpackage.lisp b/Lisp/defpackage.lisp
index bdf1eed..cb2599b 100644
--- a/Lisp/defpackage.lisp
+++ b/Lisp/defpackage.lisp
@@ -24,6 +24,9 @@
            ;; Special variables
            #:*trace-method-calls*
 
+           ;; Constants
+           #:+nil+
+
            ;; Classes
            #:id
            #:selector
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index fd7caca..072eb30 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -71,6 +71,8 @@
     :pointer
   (obj :pointer))
 
+(defcfun objcl-get-nil :pointer)
+
 
 (defun initialise-runtime ()
   "Initialise the Objective C runtime.
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index e290e50..1db5794 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -1,6 +1,12 @@
 (in-package #:mulk.objective-cl)
 
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (boundp '+nil+)
+    (defconstant +nil+
+                 (make-instance 'id :pointer (objcl-get-nil)))))
+
+
 ;;; (@* "Method invocation")
 (defun invoke (receiver message-start &rest message-components)
   "Send a message to an Objective C instance.
@@ -353,16 +359,34 @@ Returns: *result* --- the return value of the method invocation.
                 do (case (car arg-type)
                      ((:pointer)
                       (setf (argref :pointer i) arg))
-                     ((id objc-class exception)
+                     ((objc-class exception)
                       (setf (argref :pointer i) (pointer-to arg)))
                      ((selector)
-                      (ctypecase arg
-                        (selector (setf (argref :pointer i) (pointer-to arg)))))
+                      (setf (argref :pointer i) (pointer-to (selector arg))))
                      (:string
                       (setf (argref :string i)
                             (alloc-string-and-register arg)))
-                     ((array struct union) (error "~A: Not implemented."
-                                                  arg-type))
+                     ((struct union)
+                      ;; This is not very sophisticated, but, at
+                      ;; present, we don't care about the internals of
+                      ;; structs and unions much.  Functions returning
+                      ;; structs actually just give us pointers to them,
+                      ;; so we just put those pointers back into the
+                      ;; functions as arguments.
+                      (setf (argref :pointer i) arg))
+                     ((array)
+                      ;; This, too, might someday be ripped out and
+                      ;; replaced with something better.
+                      (setf (argref arg-c-type i) arg))
+                     ((id)
+                      ;; This case is actually interesting.  We can do a
+                      ;; lot of automatic conversion between different
+                      ;; kinds of stuff.  The conversion rules are
+                      ;; somewhat arbitrary, but in the absence of more
+                      ;; detailed method signature type information,
+                      ;; it's the best we can do.
+                      (setf (argref arg-c-type i)
+                            (pointer-to (coerce-object arg 'id))))
                      (t (setf (argref arg-c-type i) arg)))))
         ;; Prepare the argument typestring vector.
         (loop for i from 0
@@ -391,6 +415,7 @@ Returns: *result* --- the return value of the method invocation.
 
 
 (defun invoke-with-conversion (receiver method-name &rest args)
+  ;; TODO: Support varargs.
   (let* ((selector (selector method-name))
          (class (object-get-class receiver)))
     (multiple-value-bind (argc
@@ -499,42 +524,59 @@ Returns: *result* --- the return value of the method invocation.
 ;;; (@* "High-level Data Conversion")
 (defgeneric coerce-object (object type))
 
+
 (defcoercion id ((x id))
   x)
 
 (defcoercion id ((x class))
-  (invoke x 'self))
+  x)
 
 (defcoercion id ((x exception))
-  (invoke x 'self))
+  x)
 
 (defcoercion id ((x integer))
-  (let ((id (invoke (find-class 'ns-number)
-                    :number-with-long x)))
-    (invoke id 'retain)
-    (invoke id 'autorelease)
-    id))
-
-(defcoercion id ((x float))
-  (let ((id (invoke (find-class 'ns-number)
-                    :number-with-double x)))
-    (invoke id 'retain)
-    (invoke id 'autorelease)
-    id))
+  (primitive-invoke (find-objc-class 'ns-number)
+                    :number-with-int
+                    'id
+                    x))
+
+(defcoercion id ((x double-float))
+  (primitive-invoke (find-objc-class 'ns-number)
+                    :number-with-double
+                    'id
+                    x))
+
+(defcoercion id ((x single-float))
+  (primitive-invoke (find-objc-class 'ns-number)
+                    :number-with-float
+                    'id
+                    x))
 
 (defcoercion id ((x string))
-  (let ((id (invoke (find-class 'ns-string)
-                    :string-with-c-string x)))
-    (invoke id 'retain)
-    (invoke id 'autorelease)
-    id))
+  (primitive-invoke (find-objc-class 'ns-string)
+                    :string-with-u-t-f-8-string
+                    'id
+                    x))
+
+(defcoercion id ((x list))
+  ;; Circular lists may cause this to hang.  So may lists that contain
+  ;; themselves, as well as lists that contain other data structures
+  ;; that contain themselves or this list, and so on.
+  (apply #'primitive-invoke
+         (find-objc-class 'ns-array)
+         :array-with-objects
+         'id
+         (append (mapcar #'(lambda (element)
+                             (coerce-object element 'id))
+                         x)
+                 (list +nil+))))
 
 
 (defcoercion class ((x id))
-  (invoke x 'class))
+  (object-get-class x))
 
 (defcoercion class ((x exception))
-  (invoke x 'class))
+  (object-get-class x))
 
 (defcoercion class ((x class))
   x)
@@ -546,6 +588,9 @@ Returns: *result* --- the return value of the method invocation.
   (find-objc-class x t))
 
 
+(defcoercion integer ((x integer))
+  x)
+
 (defcoercion integer ((x id))
   (assert (objc-typep x 'ns-number))
   (invoke x 'long-value))
diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp
index 710ac94..a81b61c 100644
--- a/Lisp/utilities.lisp
+++ b/Lisp/utilities.lisp
@@ -94,13 +94,15 @@
 
 ;;; (@* "Object Representation")
 (defmethod print-object ((object id) stream)
-  (print-unreadable-object (object stream)
-    (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)))))
+  (with-slots (pointer) object
+    (if (cffi:pointer-eq pointer (pointer-to +nil+))
+        (format stream "#.~S" '+nil+)
+        (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)
+                  (cffi:pointer-address pointer))))))
 
 
 (defmethod print-object ((class objc-class) stream)