diff options
Diffstat (limited to 'Lisp')
| -rw-r--r-- | Lisp/data-types.lisp | 4 | ||||
| -rw-r--r-- | Lisp/libobjcl.lisp | 418 | ||||
| -rw-r--r-- | Lisp/method-invocation.lisp | 141 | ||||
| -rw-r--r-- | Lisp/parameters.lisp | 4 | ||||
| -rw-r--r-- | Lisp/type-conversion.lisp | 391 | ||||
| -rw-r--r-- | Lisp/utilities.lisp | 8 |
6 files changed, 480 insertions, 486 deletions
diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp index 606c0c4..b22057f 100644 --- a/Lisp/data-types.lisp +++ b/Lisp/data-types.lisp @@ -163,7 +163,9 @@ an __exception__, you can simply send it the `self' message. (defun dealloc-obj-data (obj-data) (with-foreign-slots ((type data) obj-data obj-data) - (foreign-string-free type)) + (when (and (pointerp type) + (not (null-pointer-p type))) + (foreign-string-free type))) (foreign-free obj-data)) diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp index 176423c..bf80c30 100644 --- a/Lisp/libobjcl.lisp +++ b/Lisp/libobjcl.lisp @@ -1,26 +1,58 @@ (in-package #:mulk.objective-cl) -(pushnew - (merge-pathnames (make-pathname :directory '(:relative "Objective-C" - "shared_obj") - :type "" - :name "") - (asdf:component-pathname (asdf:find-system - '#:objective-cl))) - cffi:*foreign-library-directories*) +(dolist (subdir '("shared_obj" "obj")) + (pushnew + (merge-pathnames (make-pathname :directory (list + :relative "Objective-C" subdir) + :type "" + :name "") + (asdf:component-pathname (asdf:find-system + '#:objective-cl))) + cffi:*foreign-library-directories*)) (define-foreign-library libobjcl (:unix (:or "libobjcl.so" - "libobjcl.so.0")) + "libobjcl.so.0" + "libobjcl.dylib" + "libobjcl.dylib.0")) (t (:default "libobjcl"))) (use-foreign-library libobjcl) -(defcfun ("objcl_initialise_runtime" initialise-runtime) :void) -(setf (documentation #'initialise-runtime 'function) - "Initialise the Objective C runtime. +(defcfun ("objcl_initialise_runtime" %initialise-runtime) :void) + +(defcfun ("objcl_shutdown_runtime" %shutdown-runtime) :void) + +(defcfun ("objcl_invoke_method" + %objcl-invoke-method) obj-data + (receiver obj-data) + (method-selector obj-data) + (argc :int) + &rest) + +(defcfun ("objcl_find_class" %objcl-find-class) :pointer + (class-name :string)) + +(defcfun ("objcl_class_name" %objcl-class-name) :pointer + (class obj-data)) + +(defcfun ("objcl_find_selector" %objcl-find-selector) :pointer + (selector-name :string)) + +(defcfun ("objcl_selector_name" %objcl-selector-name) :pointer + (selector obj-data)) + +(defcfun ("objcl_get_method_implementation" + %objcl-get-method-implementation) + :pointer + (object obj-data) + (selector obj-data)) + + +(defun initialise-runtime () + "Initialise the Objective C runtime. ## Description: @@ -41,12 +73,15 @@ before making any other Objective C calls. ## See also: - __shutdown-runtime__") + __shutdown-runtime__" + (when (zerop *runtime-initialisation-level*) + (%initialise-runtime)) + (atomically (incf *runtime-initialisation-level*))) -(defcfun ("objcl_shutdown_runtime" shutdown-runtime) :void) -(setf (documentation #'shutdown-runtime 'function) - "Shut the Objective C runtime down. + +(defun shutdown-runtime () + "Shut the Objective C runtime down. ## Description: @@ -64,33 +99,10 @@ objects or classes, let alone send messages to them. ## See also: - __initialise-runtime__") - - -(defcfun ("objcl_invoke_method" - %objcl-invoke-method) obj-data - (receiver obj-data) - (method-selector obj-data) - (argc :int) - &rest) - -(defcfun ("objcl_find_class" %objcl-find-class) :pointer - (class-name :string)) - -(defcfun ("objcl_class_name" %objcl-class-name) :pointer - (class obj-data)) - -(defcfun ("objcl_find_selector" %objcl-find-selector) :pointer - (selector-name :string)) - -(defcfun ("objcl_selector_name" %objcl-selector-name) :pointer - (selector obj-data)) + __initialise-runtime__" -(defcfun ("objcl_get_method_implementation" - %objcl-get-method-implementation) - :pointer - (object obj-data) - (selector obj-data)) + (when (zerop (atomically (decf *runtime-initialisation-level*))) + (%shutdown-runtime))) (declaim (ftype (function ((or string symbol) &optional t) @@ -208,57 +220,6 @@ conventional case for namespace identifiers in Objective C." (%objcl-get-method-implementation obj-obj-data sel-obj-data))) -(declaim (ftype (function ((or selector string list)) selector) - selector)) -(defun selector (designator) - "Convert an object into a selector. - -## Arguments and Values: - -*designator* --- a *selector designator*. - - -## Description: - -*selector-designator* must be a valid *selector designator*, that is: -either a __selector__ object or one of a **symbol**, a **string**, or a -**list** of **symbol**s representing a __selector__. - -If *selector-designator* is a **string** or a **list** of **symbol**s, -__find-selector__ is called and the value returned, except that if -__find-selector__ returns __nil__, an **error** is **signal**ed. - -If *selector-designator* is a single **symbol**, it is treated as if it -were a **list** whose **car** is the **symbol** and whose **cdr** is -__nil__. - -If *selector-designator* is a __selector__, it is simply returned. - - -## Examples: - - (selector \"self\") ;=> #<SELECTOR `self'> - (selector '(self)) ;=> #<SELECTOR `self'> - (selector 'self) ;=> #<SELECTOR `self'> - (selector *) ;=> #<SELECTOR `self'> - - (selector 'selph) ; error - - (selector \"stringWithCString:encoding:\") - ;=> #<SELECTOR `stringWithCString:encoding:'> - - (selector '(:string-with-c-string :encoding)) - ;=> #<SELECTOR `stringWithCString:encoding:'>" - - (etypecase designator - (selector designator) - (symbol (selector (list designator))) - ((or string list) - (or (find-selector designator) - (error "Could not find the selector designated by ~S." - designator))))) - - (declaim (ftype (function ((or selector string list)) (or null selector)) find-selector)) (defun find-selector (selector-name) @@ -314,3 +275,274 @@ by which __invoke__ converts its arguments into a *message name*. (string (find-selector-by-name selector-name)) (list (find-selector-by-name (symbol-list->message-name selector-name))))) + + +;;; (@* "Low-level Data Conversion") +(eval-when (:compile-toplevel :load-toplevel) + ;; In order to be able to dispatch over pointer types, we need to + ;; define an alias of the implementation's own pointer class. Note + ;; that this may be T (in GNU CLISP, for example), so it's a good idea + ;; 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))) + + +(declaim (ftype (function ((or selector string list)) selector) + selector)) +(defun selector (designator) + "Convert an object into a selector. + +## Arguments and Values: + +*designator* --- a *selector designator*. + + +## Description: + +*selector-designator* must be a valid *selector designator*, that is: +either a __selector__ object or one of a **symbol**, a **string**, or a +**list** of **symbol**s representing a __selector__. + +If *selector-designator* is a **string** or a **list** of **symbol**s, +__find-selector__ is called and the value returned, except that if +__find-selector__ returns __nil__, an **error** is **signal**ed. + +If *selector-designator* is a single **symbol**, it is treated as if it +were a **list** whose **car** is the **symbol** and whose **cdr** is +__nil__. + +If *selector-designator* is a __selector__, it is simply returned. + + +## Examples: + + (selector \"self\") ;=> #<SELECTOR `self'> + (selector '(self)) ;=> #<SELECTOR `self'> + (selector 'self) ;=> #<SELECTOR `self'> + (selector *) ;=> #<SELECTOR `self'> + + (selector 'selph) ; error + + (selector \"stringWithCString:encoding:\") + ;=> #<SELECTOR `stringWithCString:encoding:'> + + (selector '(:string-with-c-string :encoding)) + ;=> #<SELECTOR `stringWithCString:encoding:'>" + + (etypecase designator + (selector designator) + (symbol (selector (list designator))) + ((or string list) + (or (find-selector designator) + (error "Could not find the selector designated by ~S." + designator))))) + + +(declaim (ftype (function (*) + (values foreign-pointer &rest nil)) + lisp->obj-data)) +(defun lisp->obj-data (value) + (let ((obj-data (foreign-alloc 'obj-data)) + (type-name (lisp-value->type-name value))) + (with-foreign-slots ((type data) obj-data obj-data) + (setf (foreign-slot-value data + 'obj-data-union + (type-name->slot-name type-name)) + (typecase value + (symbol (selector value)) + ((or id objc-class selector exception) + (pointer-to value)) + (string (foreign-string-alloc value)) + (otherwise value))) + (setf type + (foreign-string-alloc (type-name->type-id type-name)))) + obj-data)) + + +(declaim (ftype (function (foreign-pointer) + (values (or number string symbol selector id + objc-class boolean foreign-pointer) + &rest nil)) + obj-data->lisp)) +(defun obj-data->lisp (obj-data) + (with-foreign-slots ((type data) obj-data obj-data) + (let* ((type-name (type-id->type-name (if (stringp type) + type + (foreign-string-to-lisp type)))) + (lisp-type (type-name->lisp-type type-name)) + (value (if (eq 'void type-name) + (values) + (foreign-slot-value data + 'obj-data-union + (type-name->slot-name type-name))))) + (case lisp-type + ((id objc-class selector exception) + (make-instance lisp-type :pointer value)) + ((string) (foreign-string-to-lisp value)) + (otherwise value))))) + + +(declaim (ftype (function (foreign-pointer) (values string &rest nil)) + foreign-string-to-lisp/dealloc)) +(defun foreign-string-to-lisp/dealloc (foreign-string) + "Convert a (possibly freshly allocated) C string into a Lisp string +and free the C string afterwards." + + (unwind-protect + (foreign-string-to-lisp foreign-string) + (foreign-string-free foreign-string))) + + +(defun parse-typespec (typestring &optional (start 0)) + "Parse a typestring like \"@0:4{_NSRange=II}8\" into something like (ID ()). + +\"rn{_NSRange=II}8\" is parsed into (STRUCT (CONST IN) +\"_NSRange\" :INTEGER :INTEGER). + +Returns: (VALUES typespec byte-position string-position)" + + (let ((init-char (char typestring start)) + (string-position start) + (qualifiers (list))) + (loop do (setq init-char (char typestring string-position)) + while (let ((qualifier (case init-char + (#\r 'const) + (#\n 'in) + (#\N 'inout) + (#\o 'out) + (#\O 'bycopy) + (#\V 'oneway) + (#\R 'byref)))) + (and qualifier + (incf string-position) + (push qualifier qualifiers)))) + (values (case init-char + ((#\{ #\() + (let* ((=-token (position #\= typestring :start start)) + (name-end (or =-token + ;; An opaque struct whose contents + ;; we don't know. + (position (ecase init-char + (#\{ #\}) + (#\( #\))) + typestring + :start start) + (error "Premature end of file in~ + typespec: ~A." + typestring))) + (struct-name (subseq typestring + (1+ string-position) + name-end))) + (list* (ecase init-char + (#\{ 'struct) + (#\( 'union)) + (if =-token + qualifiers + (cons 'opaque qualifiers)) + struct-name + (progn + (setq string-position + (if =-token + (1+ name-end) ; skip #\= + name-end)) + (loop until (char= (char typestring string-position) + (ecase init-char + (#\{ #\}) + (#\( #\)))) + collect (multiple-value-bind (typespec + byte-position + new-string-pos) + (parse-typespec + typestring + string-position) + (declare (ignore byte-position)) + (setq string-position new-string-pos) + typespec) + ;; Skip end marker (right brace/paren). + finally (incf string-position)))))) + (#\^ (list 'pointer + qualifiers + (multiple-value-bind (typespec byte-pos new-str-pos) + (parse-typespec typestring (1+ string-position)) + (declare (ignore byte-pos)) + (prog1 typespec + (setq string-position new-str-pos))))) + (#\[ (list 'array + qualifiers + (multiple-value-bind (count new-str-pos) + (parse-integer typestring + :start (1+ string-position) + :junk-allowed t) + (prog1 count + (setq string-position new-str-pos))) + (multiple-value-bind (typespec byte-pos new-str-pos) + (parse-typespec typestring string-position) + (declare (ignore byte-pos)) + ;; Skip end marker (right bracket). + (prog1 typespec + (setq string-position (1+ new-str-pos)))))) + (#\j + (list 'complex + qualifiers + (multiple-value-bind (typespec byte-pos new-str-pos) + (parse-typespec typestring (1+ string-position)) + (declare (ignore byte-pos)) + (prog1 typespec + (setq string-position new-str-pos))))) + (#\b + (let (bit-field-starting-pos + bit-field-typespec + bit-field-length + byte-position) + (multiple-value-setq (bit-field-starting-pos string-position) + (parse-integer typestring + :start (1+ string-position) + :junk-allowed t)) + (multiple-value-setq (bit-field-typespec + byte-position + string-position) + (parse-typespec typestring string-position)) + (multiple-value-setq (bit-field-length string-position) + (parse-integer typestring + :start string-position + :junk-allowed t)) + (list 'bit-field + qualifiers + bit-field-starting-pos + bit-field-length + bit-field-typespec))) + (otherwise + (prog1 (list (case init-char + (#\B :boolean) + (#\c :char) + (#\C :unsigned-char) + (#\s :short) + (#\S :unsigned-short) + (#\i :int) + (#\I :unsigned-int) + (#\l :long) + (#\L :unsigned-long) + (#\q :long-long) + (#\Q :unsigned-long-long) + (#\f :float) + (#\d :double) + (#\v :void) + (#\@ 'id) + (#\# 'objc-class) + (#\: 'selector) + (#\* :string) + (#\? :unknown)) + qualifiers) + (incf string-position)))) + #+(or) ; too greedy (=> bit-fields can't see their length!) + (multiple-value-bind (byte-position new-string-pos) + (parse-integer typestring + :start string-position + :junk-allowed t) + (setq string-position new-string-pos) + byte-position) + #-(or) nil + string-position))) diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp index 17c7cf3..83b062e 100644 --- a/Lisp/method-invocation.lisp +++ b/Lisp/method-invocation.lisp @@ -175,3 +175,144 @@ Returns: *result* --- the return value of the method invocation. (not (lower-case-p (char method-name (length prefix)))))))))) (or (method-name-starts-with "alloc") (method-name-starts-with "new")))) + + +;;; (@* "High-level Data Conversion") +(defgeneric ->id (x)) +(defgeneric ->class (x)) +(defgeneric ->integer (x)) +(defgeneric ->selector (x)) +(defgeneric ->exception (x)) +(defgeneric ->character (x)) +(defgeneric ->float (x)) +(defgeneric ->double (x)) +(defgeneric ->bool (x)) +(defgeneric ->string (x)) +(defgeneric ->pointer (x)) + + +(defmethod ->id ((x id)) + x) + +(defmethod ->id ((x class)) + (invoke x 'self)) + +(defmethod ->id ((x exception)) + (invoke x 'self)) + +(defmethod ->id ((x integer)) + (let ((id (invoke (find-class 'ns-number) + :number-with-long x))) + (invoke id 'retain) + (invoke id 'autorelease) + id)) + +(defmethod ->id ((x float)) + (let ((id (invoke (find-class 'ns-number) + :number-with-double x))) + (invoke id 'retain) + (invoke id 'autorelease) + id)) + +(defmethod ->id ((x string)) + (let ((id (invoke (find-class 'ns-string) + :string-with-c-string x))) + (invoke id 'retain) + (invoke id 'autorelease) + id)) + + +(defmethod ->class ((x id)) + (invoke x 'class)) + +(defmethod ->class ((x exception)) + (invoke x 'class)) + +(defmethod ->class ((x class)) + x) + +(defmethod ->class ((x string)) + (find-objc-class x t)) + +(defmethod ->class ((x symbol)) + (find-objc-class x t)) + + +(defmethod ->integer ((x id)) + (assert (objc-typep x 'ns-number)) + (invoke x 'long-value)) + +(defmethod ->integer ((x number)) + (truncate x)) + +(defmethod ->integer ((x null)) + 0) + +(defmethod ->integer ((x symbol)) + (assert (eq 't x)) + 1) + + +(defmethod ->selector ((x selector)) + x) + +(defmethod ->selector ((x symbol)) + (selector x)) + +(defmethod ->selector ((x string)) + (selector x)) + +(defmethod ->selector ((x cons)) + (selector x)) + + +(defmethod ->exception ((x exception)) + x) + + +(defmethod ->character ((x character)) + x) + +(defmethod ->character ((x integer)) + x) + + +(defmethod ->float ((x number)) + (float x)) + + +(defmethod ->double ((x number)) + (float x)) + + +(defmethod ->bool ((x null)) + x) + +(defmethod ->bool ((x symbol)) + (assert (eq 't x)) + x) + +(defmethod ->bool ((x integer)) + x) + + +(defmethod ->string ((x string)) + x) + +(defmethod ->string ((x foreign-pointer)) + (check-type x foreign-pointer) + x) + + +(defmethod ->pointer ((x foreign-pointer)) + (check-type x foreign-pointer) + x) + +(defmethod ->pointer ((x exception)) + (pointer-to x)) + +(defmethod ->pointer ((x c-pointer-wrapper)) + (pointer-to x)) + +(defmethod ->pointer ((x number)) + (pointer-to (->id x))) diff --git a/Lisp/parameters.lisp b/Lisp/parameters.lisp index e9e3057..cd8890d 100644 --- a/Lisp/parameters.lisp +++ b/Lisp/parameters.lisp @@ -1,8 +1,10 @@ (in-package #:mulk.objective-cl) +(defvar *runtime-initialisation-level* 0) + (defvar *skip-finalization* nil) -(defvar *skip-retaining* nil) +(defvar *skip-retaining* nil) (defvar *trace-method-calls* nil "Whether to print trace messages of all Objective C method calls. diff --git a/Lisp/type-conversion.lisp b/Lisp/type-conversion.lisp deleted file mode 100644 index d9a5431..0000000 --- a/Lisp/type-conversion.lisp +++ /dev/null @@ -1,391 +0,0 @@ -(in-package #:mulk.objective-cl) - - -;;; (@* "Low-level Data Conversion") -(declaim (ftype (function (*) - (values foreign-pointer &rest nil)) - obj-data->lisp)) -(defun lisp->obj-data (value) - (let ((obj-data (foreign-alloc 'obj-data)) - (type-name (lisp-value->type-name value))) - (with-foreign-slots ((type data) obj-data obj-data) - (setf (foreign-slot-value data - 'obj-data-union - (type-name->slot-name type-name)) - (typecase value - (symbol (selector value)) - ((or id objc-class selector exception) - (pointer-to value)) - (string (foreign-string-alloc value)) - (otherwise value))) - (setf type - (foreign-string-alloc (type-name->type-id type-name)))) - obj-data)) - - -(declaim (ftype (function (foreign-pointer) - (values (or number string symbol selector id - objc-class boolean foreign-pointer) - &rest nil)) - obj-data->lisp)) -(defun obj-data->lisp (obj-data) - (with-foreign-slots ((type data) obj-data obj-data) - (let* ((type-name (type-id->type-name (foreign-string-to-lisp type))) - (lisp-type (type-name->lisp-type type-name)) - (value (if (eq 'void type-name) - (values) - (foreign-slot-value data - 'obj-data-union - (type-name->slot-name type-name))))) - (case lisp-type - ((id objc-class selector exception) - (make-instance lisp-type :pointer value)) - ((string) (foreign-string-to-lisp value)) - (otherwise value))))) - - -(defmacro with-foreign-conversion (bindings &body body) - `(with-foreign-objects - ,(mapcar #'(lambda (name-value-pair) - (destructuring-bind (name value) - name-value-pair - `(,name (lisp->obj-data ,value)))) - bindings) - ,@body)) - - -(defmacro with-foreign-objects (bindings &body body) - `(let ,(mapcar #'(lambda (name-value-pair) - (destructuring-bind (name value) - name-value-pair - `(,name ,value))) - bindings) - (unwind-protect - (progn ,@body) - ,@(mapcar #'(lambda (name-value-pair) - `(dealloc-obj-data ,(first name-value-pair))) - bindings)))) - - -(declaim (ftype (function (foreign-pointer) (values string &rest nil)) - foreign-string-to-lisp/dealloc)) -(defun foreign-string-to-lisp/dealloc (foreign-string) - "Convert a (possibly freshly allocated) C string into a Lisp string -and free the C string afterwards." - - (unwind-protect - (foreign-string-to-lisp foreign-string) - (foreign-string-free foreign-string))) - - -(defun parse-typespec (typestring &optional (start 0)) - "Parse a typestring like \"@0:4{_NSRange=II}8\" into something like (ID ()). - -\"rn{_NSRange=II}8\" is parsed into (STRUCT (CONST IN) -\"_NSRange\" :INTEGER :INTEGER). - -Returns: (VALUES typespec byte-position string-position)" - - (let ((init-char (char typestring start)) - (string-position start) - (qualifiers (list))) - (loop do (setq init-char (char typestring string-position)) - while (let ((qualifier (case init-char - (#\r 'const) - (#\n 'in) - (#\N 'inout) - (#\o 'out) - (#\O 'bycopy) - (#\V 'oneway) - (#\R 'byref)))) - (and qualifier - (incf string-position) - (push qualifier qualifiers)))) - (values (case init-char - ((#\{ #\() - (let* ((=-token (position #\= typestring :start start)) - (name-end (or =-token - ;; An opaque struct whose contents - ;; we don't know. - (position (ecase init-char - (#\{ #\}) - (#\( #\))) - typestring - :start start) - (error "Premature end of file in~ - typespec: ~A." - typestring))) - (struct-name (subseq typestring - (1+ string-position) - name-end))) - (list* (ecase init-char - (#\{ 'struct) - (#\( 'union)) - (if =-token - qualifiers - (cons 'opaque qualifiers)) - struct-name - (progn - (setq string-position - (if =-token - (1+ name-end) ; skip #\= - name-end)) - (loop until (char= (char typestring string-position) - (ecase init-char - (#\{ #\}) - (#\( #\)))) - collect (multiple-value-bind (typespec - byte-position - new-string-pos) - (parse-typespec - typestring - string-position) - (declare (ignore byte-position)) - (setq string-position new-string-pos) - typespec) - ;; Skip end marker (right brace/paren). - finally (incf string-position)))))) - (#\^ (list 'pointer - qualifiers - (multiple-value-bind (typespec byte-pos new-str-pos) - (parse-typespec typestring (1+ string-position)) - (declare (ignore byte-pos)) - (prog1 typespec - (setq string-position new-str-pos))))) - (#\[ (list 'array - qualifiers - (multiple-value-bind (count new-str-pos) - (parse-integer typestring - :start (1+ string-position) - :junk-allowed t) - (prog1 count - (setq string-position new-str-pos))) - (multiple-value-bind (typespec byte-pos new-str-pos) - (parse-typespec typestring string-position) - (declare (ignore byte-pos)) - ;; Skip end marker (right bracket). - (prog1 typespec - (setq string-position (1+ new-str-pos)))))) - (#\j - (list 'complex - qualifiers - (multiple-value-bind (typespec byte-pos new-str-pos) - (parse-typespec typestring (1+ string-position)) - (declare (ignore byte-pos)) - (prog1 typespec - (setq string-position new-str-pos))))) - (#\b - (let (bit-field-starting-pos - bit-field-typespec - bit-field-length - byte-position) - (multiple-value-setq (bit-field-starting-pos string-position) - (parse-integer typestring - :start (1+ string-position) - :junk-allowed t)) - (multiple-value-setq (bit-field-typespec - byte-position - string-position) - (parse-typespec typestring string-position)) - (multiple-value-setq (bit-field-length string-position) - (parse-integer typestring - :start string-position - :junk-allowed t)) - (list 'bit-field - qualifiers - bit-field-starting-pos - bit-field-length - bit-field-typespec))) - (otherwise - (prog1 (list (case init-char - (#\B :boolean) - (#\c :char) - (#\C :unsigned-char) - (#\s :short) - (#\S :unsigned-short) - (#\i :int) - (#\I :unsigned-int) - (#\l :long) - (#\L :unsigned-long) - (#\q :long-long) - (#\Q :unsigned-long-long) - (#\f :float) - (#\d :double) - (#\v :void) - (#\@ 'id) - (#\# 'objc-class) - (#\: 'selector) - (#\* :string) - (#\? :unknown)) - qualifiers) - (incf string-position)))) - #+(or) ; too greedy (=> bit-fields can't see their length!) - (multiple-value-bind (byte-position new-string-pos) - (parse-integer typestring - :start string-position - :junk-allowed t) - (setq string-position new-string-pos) - byte-position) - #-(or) nil - string-position))) - - -;;; (@* "High-level Data Conversion") -(eval-when (:compile-toplevel :load-toplevel) - ;; In order to be able to dispatch over pointer types, we need to - ;; define an alias of the implementation's own pointer class. Note - ;; that this may be T (in GNU CLISP, for example), so it's a good idea - ;; 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))) - - -(defun objc-typep (x class-designator) - (objc-eql (invoke x 'class) - (etypecase x - (class x) - (id (invoke x 'class)) - ((or string symbol) (find-objc-class class-designator t))))) - - -(defgeneric ->id (x)) -(defgeneric ->class (x)) -(defgeneric ->integer (x)) -(defgeneric ->selector (x)) -(defgeneric ->exception (x)) -(defgeneric ->character (x)) -(defgeneric ->float (x)) -(defgeneric ->double (x)) -(defgeneric ->bool (x)) -(defgeneric ->string (x)) -(defgeneric ->pointer (x)) - - -(defmethod ->id ((x id)) - x) - -(defmethod ->id ((x class)) - (invoke x 'self)) - -(defmethod ->id ((x exception)) - (invoke x 'self)) - -(defmethod ->id ((x integer)) - (let ((id (invoke (find-class 'ns-number) - :number-with-long x))) - (invoke id 'retain) - (invoke id 'autorelease) - id)) - -(defmethod ->id ((x float)) - (let ((id (invoke (find-class 'ns-number) - :number-with-double x))) - (invoke id 'retain) - (invoke id 'autorelease) - id)) - -(defmethod ->id ((x string)) - (let ((id (invoke (find-class 'ns-string) - :string-with-c-string x))) - (invoke id 'retain) - (invoke id 'autorelease) - id)) - - -(defmethod ->class ((x id)) - (invoke x 'class)) - -(defmethod ->class ((x exception)) - (invoke x 'class)) - -(defmethod ->class ((x class)) - x) - -(defmethod ->class ((x string)) - (find-objc-class x t)) - -(defmethod ->class ((x symbol)) - (find-objc-class x t)) - - -(defmethod ->integer ((x id)) - (assert (objc-typep x 'ns-number)) - (invoke x 'long-value)) - -(defmethod ->integer ((x number)) - (truncate x)) - -(defmethod ->integer ((x null)) - 0) - -(defmethod ->integer ((x symbol)) - (assert (eq 't x)) - 1) - - -(defmethod ->selector ((x selector)) - x) - -(defmethod ->selector ((x symbol)) - (selector x)) - -(defmethod ->selector ((x string)) - (selector x)) - -(defmethod ->selector ((x cons)) - (selector x)) - - -(defmethod ->exception ((x exception)) - x) - - -(defmethod ->character ((x character)) - x) - -(defmethod ->character ((x integer)) - x) - - -(defmethod ->float ((x number)) - (float x)) - - -(defmethod ->double ((x number)) - (float x)) - - -(defmethod ->bool ((x null)) - x) - -(defmethod ->bool ((x symbol)) - (assert (eq 't x)) - x) - -(defmethod ->bool ((x integer)) - x) - - -(defmethod ->string ((x string)) - x) - -(defmethod ->string ((x foreign-pointer)) - (check-type x foreign-pointer) - x) - - -(defmethod ->pointer ((x foreign-pointer)) - (check-type x foreign-pointer) - x) - -(defmethod ->pointer ((x exception)) - (pointer-to x)) - -(defmethod ->pointer ((x c-pointer-wrapper)) - (pointer-to x)) - -(defmethod ->pointer ((x number)) - (pointer-to (->id x))) diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp index 3a8e5da..29efb60 100644 --- a/Lisp/utilities.lisp +++ b/Lisp/utilities.lisp @@ -22,6 +22,14 @@ (invoke y :is-equal x))))) +(defun objc-typep (x class-designator) + (objc-eql (invoke x 'class) + (etypecase x + (class x) + (id (invoke x 'class)) + ((or string symbol) (find-objc-class class-designator t))))) + + (defmethod objc-eql (x y) (cl:eql x y)) |