summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2007-09-18 02:35:51 +0200
committerMatthias Benkard <code@mail.matthias.benkard.de>2007-09-18 02:35:51 +0200
commit812ce570c5712dcf0006a1bbd88c026b6953d4e0 (patch)
tree732c276f9f8271f3bf1921da008179afde134d61
parentc93a74f1befea75be769fb47968e67568139954d (diff)
INVOKE-WITH-CONVERSION: Support arrays, structs, and unions, and convert Lisp objects into Objective-C instances automatically.
darcs-hash:decc92c91c315c1e347b9f5327bfb6e21ccca9a8
-rw-r--r--Lisp/defpackage.lisp3
-rw-r--r--Lisp/libobjcl.lisp2
-rw-r--r--Lisp/method-invocation.lisp97
-rw-r--r--Lisp/utilities.lisp16
-rw-r--r--Objective-C/libobjcl.h3
-rw-r--r--Objective-C/libobjcl.m7
6 files changed, 95 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)
diff --git a/Objective-C/libobjcl.h b/Objective-C/libobjcl.h
index 27ffd01..9c673f7 100644
--- a/Objective-C/libobjcl.h
+++ b/Objective-C/libobjcl.h
@@ -91,3 +91,6 @@ objcl_object_get_class (id obj);
Class
objcl_object_get_meta_class (id obj);
+
+id
+objcl_get_nil (void);
diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m
index bc89a32..1a17a44 100644
--- a/Objective-C/libobjcl.m
+++ b/Objective-C/libobjcl.m
@@ -502,3 +502,10 @@ objcl_object_get_meta_class (id obj)
return object_get_meta_class (obj);
#endif
}
+
+
+id
+objcl_get_nil (void)
+{
+ return nil;
+}