Code reorganisation.

darcs-hash:be8c8af8504b2ce63cde33a893542d3590abd703

1 files changed, 0 insertions, 391 deletions

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