diff options
| -rw-r--r-- | Lisp/defpackage.lisp | 3 | ||||
| -rw-r--r-- | Lisp/libobjcl.lisp | 2 | ||||
| -rw-r--r-- | Lisp/method-invocation.lisp | 97 | ||||
| -rw-r--r-- | Lisp/utilities.lisp | 16 | ||||
| -rw-r--r-- | Objective-C/libobjcl.h | 3 | ||||
| -rw-r--r-- | Objective-C/libobjcl.m | 7 |
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; +} |