Code reorganisation.

darcs-hash:be8c8af8504b2ce63cde33a893542d3590abd703

1 files changed, 325 insertions, 93 deletions

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)))