summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
Diffstat (limited to 'Lisp')
-rw-r--r--Lisp/data-types.lisp4
-rw-r--r--Lisp/libobjcl.lisp418
-rw-r--r--Lisp/method-invocation.lisp141
-rw-r--r--Lisp/parameters.lisp4
-rw-r--r--Lisp/type-conversion.lisp391
-rw-r--r--Lisp/utilities.lisp8
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))