Make TYPESPEC a struct type.

darcs-hash:e915984995e05d399993c4d602a7c4949053ca66

7 files changed, 205 insertions, 136 deletions

diff --git a/Lisp/class-definition.lisp b/Lisp/class-definition.lisp
index 467965d..7410847 100644
--- a/Lisp/class-definition.lisp
+++ b/Lisp/class-definition.lisp
@@ -197,6 +197,7 @@ __define-objective-c-method__"
                  :type (or null string))
    (foreign-type :initarg :foreign-type
                  :initform nil
+                 :type typespec
                  :accessor slot-definition-foreign-type)
    (foreign-slot :initarg :foreign-slot
                  :initform nil
@@ -277,7 +278,7 @@ __define-objective-c-method__"
             :initfunction (or initfunction
                               #'(lambda ()
                                   (or initform *objcl-foreign-default-initform*)))
-            :foreign-type foreign-type
+            :foreign-type (typespec foreign-type)
             :foreign-name foreign-name
             :foreign-slot foreign-slot
             :class class))))
diff --git a/Lisp/method-definition.lisp b/Lisp/method-definition.lisp
index ad3b45a..377247e 100644
--- a/Lisp/method-definition.lisp
+++ b/Lisp/method-definition.lisp
@@ -407,7 +407,7 @@ __define-objective-c-generic-function__.
          (method-name (generic-function-name->selector
                        (generic-function-name gf)))
          (registered-p (foreign-class-registered-p class))
-         (return-type (method-return-type method))
+         (return-type (typespec (method-return-type method)))
          (method-argument-types (method-argument-types method))
          (argument-types (list* (first method-argument-types)
                                 :selector
@@ -421,9 +421,10 @@ __define-objective-c-generic-function__.
                                   (gensym "ARG"))
                               argument-types)))
     (eval (loop for type in argument-types
+                for typespec = (typespec type)
                 for symbol in arg-symbols
-                collect (list symbol (typespec->c-type type)) into cffi-lambda-list
-                if (member (typespec-primary-type type) '(:id :class :selector))
+                collect (list symbol (typespec->c-type typespec)) into cffi-lambda-list
+                if (member (typespec-primary-type typespec) '(:id :class :selector))
                   collect `(intern-pointer-wrapper ',type :pointer ,symbol)
                     into arguments
                 else
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 66f7368..c4ba3fc 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -263,25 +263,26 @@ easier to use with __apply__.
 
 (defun primitive-invoke (receiver method-name return-type &rest args)
   (flet ((ad-hoc-value->typespec (arg)
-           (etypecase arg
-             ;; According to Allegro CL, strings
-             ;; are POINTERP (and thus elements of
-             ;; the C-POINTER type), so they have
-             ;; to come first in this TYPECASE
-             ;; form.  Weird.
-             ;;
-             ;; By the way, pointers are
-             ;; represented as integers in Allegro
-             ;; CL, so all integers are POINTERP,
-             ;; too.
-             (string '(:string ()))
-             (selector '(selector ()))
-             (c-pointer-wrapper '(id ()))
-             (c-pointer '(:pointer ()))
-             (integer '(:int ())))))
-    (let ((return-typespec `(,return-type ()))
-          (arg-typespecs (list* '(id ())
-                                '(selector ())
+           (typespec
+            (etypecase arg
+              ;; According to Allegro CL, strings
+              ;; are POINTERP (and thus elements of
+              ;; the C-POINTER type), so they have
+              ;; to come first in this TYPECASE
+              ;; form.  Weird.
+              ;;
+              ;; By the way, pointers are
+              ;; represented as integers in Allegro
+              ;; CL, so all integers are POINTERP,
+              ;; too.
+              (string '(:string ()))
+              (selector '(selector ()))
+              (c-pointer-wrapper '(id ()))
+              (c-pointer '(:pointer ()))
+              (integer '(:int ()))))))
+    (let ((return-typespec (typespec `(,return-type ())))
+          (arg-typespecs (list* (typespec '(id ()))
+                                (typespec '(selector ()))
                                 (mapcar #'ad-hoc-value->typespec args))))
       (low-level-invoke receiver
                         (selector method-name)
@@ -387,7 +388,7 @@ easier to use with __apply__.
                 for arg in args
                 for arg-type in (cddr arg-types) ;skip the first two arguments
                 for arg-c-type in (cddr arg-c-types) ;likewise
-                do (case (car arg-type)
+                do (case (typespec-primary-type arg-type)
                      ((:pointer)
                       (setf (argref :pointer i) arg))
                      ((objective-c-class exception)
diff --git a/Lisp/tests.lisp b/Lisp/tests.lisp
index 902cc34..95827b8 100644
--- a/Lisp/tests.lisp
+++ b/Lisp/tests.lisp
@@ -29,7 +29,8 @@
                           #:foreign-class-registered-p
                           #:define-objective-c-method #:defobjcmethod
                           #:objective-c-generic-function #:objective-c-method
-                          #:+nil+ #:+yes+ #:+no+ #:selector))
+                          #:+nil+ #:+yes+ #:+no+ #:selector
+                          #:typespec-primary-type))
 (in-package #:mulk.objective-cl.tests)
 (in-root-suite)
 
@@ -101,7 +102,7 @@
                                          "Klum."))))
   (is (primitive-invoke (find-objc-class 'ns-string)
                         :is-subclass-of-class
-                        (first (parse-typespec "c" t))
+                        (typespec-primary-type (parse-typespec "c" t))
                         (find-objc-class 'ns-object)))
   ;; performSelector:withObject: cannot be used with non-id return
   ;; types.
@@ -135,63 +136,67 @@
 #.(disable-objective-c-syntax)
 
 
+(defun typespec-equalp (t1 t2)
+  (equalp (objcl::typespec t1)
+          (objcl::typespec t2)))
+
 (deftest parsing-typespecs ()
-  (is (equal (parse-typespec "@0:4{_NSRange=II}8")
-             '(id ())))
-  (is (equal (parse-typespec ":4{_NSRange=II}8")
-             '(selector ())))
-  (is (equal (parse-typespec "{_NSRange=II}8")
-             '(struct () "_NSRange"
-               (:unsigned-int ())
-               (:unsigned-int ()))))
-  (is (equal (parse-typespec "rnNoV^V[10rjd]4")
-             ;; Actually, the order of the qualifiers doesn't
-             ;; matter, which means that this test is dumber than
-             ;; it ought to be.
-             '(pointer (oneway out inout in const)
-               (array (oneway)
-                10
-                (complex (const) (:double nil))))))
-  (is (equal (parse-typespec "ROi")
-             ;; Here, too, the order of the qualifiers is irrelevant.
-             '(:int (bycopy byref))))
-  (is (equal (parse-typespec "(?=)")
-             '(union () "?")))
-  (is (equal (parse-typespec "{?=rb123rjf456iii}")
-             (if (eq objcl::+runtime-type+ :gnu)
-                 '(struct () "?"
-                   (bit-field (const) 123 456
-                    (complex (const) (:float ())))
-                   (:int ())
-                   (:int ())
-                   (:int ()))
-                 '(struct () "?"
-                   (bit-field (const) nil 123)
-                   (complex (const) (:float ()))
-                   (:unrecognised () #\4)
-                   (:unrecognised () #\5)
-                   (:unrecognised () #\6)
-                   (:int ())
-                   (:int ())
-                   (:int ())))))
-  (is (equal (parse-typespec "^[100{?=ii}]")
-             '(pointer ()
-               (array () 100
-                (struct () "?" (:int ()) (:int ()))))))
-  (is (equal (parse-typespec "{?=BiIlLqQfd@#:*?}")
-             '(struct () "?"
-               (:boolean ())
-               (:int ())
-               (:unsigned-int ())
-               (:long ())
-               (:unsigned-long ())
-               (:long-long ())
-               (:unsigned-long-long ())
-               (:float ())
-               (:double ())
-               (id ()) (objective-c-class ()) (selector ())
-               (:string ())
-               (:unknown ()))))
+  (is (typespec-equalp (parse-typespec "@0:4{_NSRange=II}8")
+                       '(id ())))
+  (is (typespec-equalp (parse-typespec ":4{_NSRange=II}8")
+                       '(selector ())))
+  (is (typespec-equalp (parse-typespec "{_NSRange=II}8")
+                       '(struct () "_NSRange"
+                         (:unsigned-int ())
+                         (:unsigned-int ()))))
+  (is (typespec-equalp (parse-typespec "rnNoV^V[10rjd]4")
+                       ;; Actually, the order of the qualifiers doesn't
+                       ;; matter, which means that this test is dumber than
+                       ;; it ought to be.
+                       '(pointer (oneway out inout in const)
+                         (array (oneway)
+                          10
+                          (complex (const) (:double nil))))))
+  (is (typespec-equalp (parse-typespec "ROi")
+                       ;; Here, too, the order of the qualifiers is irrelevant.
+                       '(:int (bycopy byref))))
+  (is (typespec-equalp (parse-typespec "(?=)")
+                       '(union () "?")))
+  (is (typespec-equalp (parse-typespec "{?=rb123rjf456iii}")
+                       (if (eq objcl::+runtime-type+ :gnu)
+                           '(struct () "?"
+                             (bit-field (const) 123 456
+                              (complex (const) (:float ())))
+                             (:int ())
+                             (:int ())
+                             (:int ()))
+                           '(struct () "?"
+                             (bit-field (const) nil 123)
+                             (complex (const) (:float ()))
+                             (:unrecognised () #\4)
+                             (:unrecognised () #\5)
+                             (:unrecognised () #\6)
+                             (:int ())
+                             (:int ())
+                             (:int ())))))
+  (is (typespec-equalp (parse-typespec "^[100{?=ii}]")
+                       '(pointer ()
+                         (array () 100
+                          (struct () "?" (:int ()) (:int ()))))))
+  (is (typespec-equalp (parse-typespec "{?=BiIlLqQfd@#:*?}")
+                       '(struct () "?"
+                         (:boolean ())
+                         (:int ())
+                         (:unsigned-int ())
+                         (:long ())
+                         (:unsigned-long ())
+                         (:long-long ())
+                         (:unsigned-long-long ())
+                         (:float ())
+                         (:double ())
+                         (id ()) (objective-c-class ()) (selector ())
+                         (:string ())
+                         (:unknown ()))))
   (let ((funky-spec (parse-typespec "{?=cC}")))
     (is (member funky-spec
                 '((struct () "?"
@@ -200,7 +205,7 @@
                   (struct () "?"
                    (:int ((nominally :char)))
                    (:unsigned-int ((nominally :unsigned-char)))))
-                :test #'equalp)))
+                :test #'typespec-equalp)))
   (let ((funky-spec (parse-typespec "{?=sS}")))
     (is (member funky-spec
                 '((struct () "?"
@@ -209,29 +214,29 @@
                   (struct () "?"
                    (:int ((nominally :short)))
                    (:unsigned-int ((nominally :unsigned-short)))))
-                :test #'equalp)))
-  (is (equal (parse-typespec "{Mulk=*{Untermulk={Unteruntermulk=}}i}")
-             '(struct () "Mulk"
-               (:string ())
-               (struct () "Untermulk"
-                (struct () "Unteruntermulk"))
-               (:int ()))))
-  (is (equal (parse-typespec "^^{OpaqueStruct}")
-             '(pointer ()
-               (pointer ()
-                (struct (opaque) "OpaqueStruct")))))
-  (is (equal (parse-typespec "^{_GSKeyBinding=ii@\"GSKeyBindingAction\"@\"GSKeyBindingTable\"}")
-             '(pointer ()
-               (struct () "_GSKeyBinding"
-                (:int ())
-                (:int ())
-                (id ((:type "GSKeyBindingAction")))
-                (id ((:type "GSKeyBindingTable")))))))
-  (is (equal (parse-typespec "{?=\"next\"@\"GCObject\"\"previous\"@\"GCObject\"\"flags\"{?=}}")
-             '(struct () "?"
-               (id ((:type "GCObject") (:name "next")))
-               (id ((:type "GCObject") (:name "previous")))
-               (struct ((:name "flags")) "?")))))
+                :test #'typespec-equalp)))
+  (is (typespec-equalp (parse-typespec "{Mulk=*{Untermulk={Unteruntermulk=}}i}")
+                       '(struct () "Mulk"
+                         (:string ())
+                         (struct () "Untermulk"
+                          (struct () "Unteruntermulk"))
+                         (:int ()))))
+  (is (typespec-equalp (parse-typespec "^^{OpaqueStruct}")
+                       '(pointer ()
+                         (pointer ()
+                          (struct (opaque) "OpaqueStruct")))))
+  (is (typespec-equalp (parse-typespec "^{_GSKeyBinding=ii@\"GSKeyBindingAction\"@\"GSKeyBindingTable\"}")
+                       '(pointer ()
+                         (struct () "_GSKeyBinding"
+                          (:int ())
+                          (:int ())
+                          (id ((:type "GSKeyBindingAction")))
+                          (id ((:type "GSKeyBindingTable")))))))
+  (is (typespec-equalp (parse-typespec "{?=\"next\"@\"GCObject\"\"previous\"@\"GCObject\"\"flags\"{?=}}")
+                       '(struct () "?"
+                         (id ((:type "GCObject") (:name "next")))
+                         (id ((:type "GCObject") (:name "previous")))
+                         (struct ((:name "flags")) "?")))))
 
 
 (deftest printing-typespecs ()
diff --git a/Lisp/type-conversion-policy.lisp b/Lisp/type-conversion-policy.lisp
index ec9d071..ac99890 100644
--- a/Lisp/type-conversion-policy.lisp
+++ b/Lisp/type-conversion-policy.lisp
@@ -19,6 +19,9 @@
 
 
 (defmethod coerce-object (object (type list))
+  (coerce-object object (typespec type)))
+
+(defmethod coerce-object (object (type typespec))
   (coerce-object object (typespec-primary-type type)))
 
 
diff --git a/Lisp/type-conversion.lisp b/Lisp/type-conversion.lisp
index eac3687..9796104 100644
--- a/Lisp/type-conversion.lisp
+++ b/Lisp/type-conversion.lisp
@@ -25,7 +25,7 @@
               (typespec-primary-type typespec))
       ((id objective-c-class exception selector)
        (let ((*skip-retaining* skip-retaining-p))
-         (intern-pointer-wrapper (car (typespec typespec))
+         (intern-pointer-wrapper (typespec-primary-type typespec)
                                  :pointer (cffi:mem-ref foreign-value-cell
                                                         c-type))))
       ((:char :unsigned-char)
diff --git a/Lisp/type-handling.lisp b/Lisp/type-handling.lisp
index a37f756..73e3107 100644
--- a/Lisp/type-handling.lisp
+++ b/Lisp/type-handling.lisp
@@ -18,7 +18,66 @@
 (in-package #:mulk.objective-cl)
 
 
+(defstruct typespec
+  primary-type
+  qualifiers
+  name
+  children
+  bit-field-start
+  bit-field-length
+  bit-field-type
+  array-length)
+
+
 (defun parse-typespec (typestring &optional return-type-p (start 0))
+  (list->typespec (parse-typespec-to-list typestring return-type-p start)))
+
+
+(defun list->typespec (list)
+  (destructuring-bind (primary-type qualifiers . name-and-children) list
+    (let ((name (case primary-type
+                  ((struct union :struct :union)
+                   (first name-and-children))
+                  (otherwise nil)))
+          (children (case primary-type
+                      ((struct union array :struct :union :array)
+                       (rest name-and-children))
+                      (otherwise name-and-children))))
+      (case primary-type
+        ((:bit-field bit-field)
+         (destructuring-bind (start length type) name-and-children
+           (make-typespec :primary-type :bit-field
+                          :qualifiers qualifiers
+                          :bit-field-start start
+                          :bit-field-length length
+                          :bit-field-type type)))
+        ((:array array)
+         (make-typespec :primary-type primary-type
+                        :qualifiers qualifiers
+                        :array-length (first name-and-children)
+                        :children (mapcar #'list->typespec children)))
+        (otherwise
+         (make-typespec :primary-type primary-type
+                        :qualifiers qualifiers
+                        :name name
+                        :children (mapcar #'list->typespec children)))))))
+
+
+(defun typespec->list (typespec)
+  (with-slots (primary-type qualifiers name children bit-field-start
+               bit-field-length bit-field-type array-length)
+      typespec
+    `(,primary-type
+      ,qualifiers
+      ,@(when name (list name))
+      ,@(when bit-field-start (list bit-field-start))
+      ,@(when bit-field-length (list bit-field-length))
+      ,@(when bit-field-type (list bit-field-type))
+      ,@(when array-length (list array-length))
+      ,@(mapcar #'typespec->list children))))
+
+
+(defun parse-typespec-to-list (typestring &optional return-type-p (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)
@@ -97,7 +156,7 @@ Returns: (VALUES typespec byte-position string-position)"
                                 collect (multiple-value-bind (typespec
                                                               byte-position
                                                               new-string-pos)
-                                            (parse-typespec
+                                            (parse-typespec-to-list
                                              typestring
                                              nil
                                              string-position)
@@ -109,9 +168,9 @@ Returns: (VALUES typespec byte-position string-position)"
               (#\^ (list 'pointer
                          qualifiers
                          (multiple-value-bind (typespec byte-pos new-str-pos)
-                             (parse-typespec typestring
-                                             nil
-                                             (1+ string-position))
+                             (parse-typespec-to-list typestring
+                                                     nil
+                                                     (1+ string-position))
                            (declare (ignore byte-pos))
                            (prog1 typespec
                                   (setq string-position new-str-pos)))))
@@ -124,7 +183,7 @@ Returns: (VALUES typespec byte-position string-position)"
                            (prog1 count
                                   (setq string-position new-str-pos)))
                          (multiple-value-bind (typespec byte-pos new-str-pos)
-                             (parse-typespec typestring nil string-position)
+                             (parse-typespec-to-list typestring nil string-position)
                            (declare (ignore byte-pos))
                            ;; Skip end marker (right bracket).
                            (prog1 typespec
@@ -133,7 +192,7 @@ Returns: (VALUES typespec byte-position string-position)"
                (list 'complex
                      qualifiers
                      (multiple-value-bind (typespec byte-pos new-str-pos)
-                         (parse-typespec typestring nil (1+ string-position))
+                         (parse-typespec-to-list typestring nil (1+ string-position))
                        (declare (ignore byte-pos))
                        (prog1 typespec
                               (setq string-position new-str-pos)))))
@@ -150,7 +209,7 @@ Returns: (VALUES typespec byte-position string-position)"
                      (multiple-value-setq (bit-field-typespec
                                            byte-position
                                            string-position)
-                         (parse-typespec typestring nil string-position))
+                         (parse-typespec-to-list typestring nil string-position))
                      (multiple-value-setq (bit-field-length string-position)
                          (parse-integer typestring
                                         :start string-position
@@ -232,8 +291,9 @@ Returns: (VALUES typespec byte-position string-position)"
 
 (defun typespec (typespec-designator)
   (etypecase typespec-designator
-    (symbol (list typespec-designator ()))
-    (list typespec-designator)))
+    (symbol (make-typespec :primary-type typespec-designator))
+    (list (list->typespec typespec-designator))
+    (typespec typespec-designator)))
 
 
 (defun print-typespec-to-string (typespec)
@@ -244,7 +304,7 @@ Returns: (VALUES typespec byte-position string-position)"
 (defun print-typespec (typespec &optional (stream *standard-output*))
   "Convert a TYPESPEC into a typestring and write the result to a STREAM."
   (destructuring-bind (type-name modifiers &rest rest)
-      (typespec typespec)
+      (typespec->list (typespec typespec))
     (dolist (modifier modifiers)
       (format stream "~A" (case modifier
                             (const #\r)
@@ -275,20 +335,22 @@ Returns: (VALUES typespec byte-position string-position)"
                         (format stream "~C" (ecase type-name
                                               (struct #\})
                                               (union #\))))))
-      ((bit-field) (if (eq +runtime-type+ :gnu)
-                       (destructuring-bind (alignment length . children) rest
-                         (format stream "b~D" alignment)
-                         (dolist (child children)
-                           (print-typespec child stream))
-                         (format stream "~D" length))
-                       (destructuring-bind (alignment length . children) rest
-                         (declare (ignore alignment children))
-                         (format stream "b~D" length))))
-      ((array) (destructuring-bind (length . children) rest
-                 (format stream "[~D" length)
-                 (dolist (child children)
-                   (print-typespec child stream))
-                 (format stream "]")))
+      ((bit-field :bit-field)
+       (if (eq +runtime-type+ :gnu)
+           (destructuring-bind (alignment length . children) rest
+             (format stream "b~D" alignment)
+             (dolist (child children)
+               (print-typespec child stream))
+             (format stream "~D" length))
+           (destructuring-bind (alignment length . children) rest
+             (declare (ignore alignment children))
+             (format stream "b~D" length))))
+      ((array :array)
+       (destructuring-bind (length . children) rest
+         (format stream "[~D" length)
+         (dolist (child children)
+           (print-typespec child stream))
+         (format stream "]")))
       ((:unrecognised) (format stream "~{~A~}" rest))
       (t (format stream "~A" (typespec-name->type-id type-name))
          (dolist (child rest)
@@ -301,8 +363,4 @@ Returns: (VALUES typespec byte-position string-position)"
   ;; type found.
   (cadr (find-if #'(lambda (x) (and (consp x)
                                     (eq (car x) 'nominally)))
-                 (cadr (typespec typespec)))))
-
-
-(defun typespec-primary-type (typespec)
-  (car (typespec typespec)))
+                 (typespec-qualifiers (typespec typespec)))))