Implement a typespec parser for the GNU Objective-C runtime.

darcs-hash:b1e4d767b18dce617c5df6920ca592111604c2a6

2 files changed, 195 insertions, 1 deletions

diff --git a/Lisp/tests.lisp b/Lisp/tests.lisp
index eec76ee..7d6ddb9 100644
--- a/Lisp/tests.lisp
+++ b/Lisp/tests.lisp
@@ -1,7 +1,11 @@
 (defpackage #:mulk.objective-cl.tests
   (:nicknames #:objcl-tests #:objective-cl-tests #:mulk.objcl-tests)
   (:use #:lift #:mulk.objective-cl #:cl)
-  (:export #:run-all-tests))
+  (:export #:run-all-tests)
+  (:shadowing-import-from #:objcl
+                          #:struct #:union #:pointer #:oneway #:out #:in
+                          #:inout #:const #:parse-typespec #:objc-class
+                          #:bit-field))
 (in-package #:mulk.objective-cl.tests)
 
 
@@ -64,6 +68,64 @@
                       withObject: [NSObject class]]))))
 
 
+(deftestsuite parsing-typespecs (objective-cl)
+  ()
+  (:equality-test #'equal)
+  (:tests
+   ((ensure-same (parse-typespec "@0:4{_NSRange=II}8")
+                 '(id ())))
+   ((ensure-same (parse-typespec ":4{_NSRange=II}8")
+                 '(selector ())))
+   ((ensure-same (parse-typespec "{_NSRange=II}8")
+                 '(struct () "_NSRange"
+                   (:unsigned-int ())
+                   (:unsigned-int ()))))
+   ((ensure-same (parse-typespec "rnNoV^V[10rjd]4")
+                 ;; Actually, the order of the qualifiers is not
+                 ;; important, which means that this test is too dumb.
+                 '(pointer (oneway out inout in const)
+                   (array (oneway)
+                    10
+                    (complex (const) (:double nil))))))
+   ((ensure-same (parse-typespec "(?=)")
+                 '(union () "?")))
+   ((ensure-same (parse-typespec "{?=rb123rjf456iii}")
+                 '(struct () "?"
+                   (bit-field (const) 123 456
+                    (complex (const) (:float ())))
+                   (:int ())
+                   (:int ())
+                   (:int ()))))
+   ((ensure-same (parse-typespec "^[100{?=ii}]")
+                 '(pointer ()
+                   (array () 100
+                    (struct () "?" (:int ()) (:int ()))))))
+   ((ensure-same (parse-typespec "{?=BcCsSiIlLqQfd@#:*?}")
+                 '(struct () "?"
+                   (:boolean ())
+                   (:char ())
+                   (:unsigned-char ())
+                   (:short ())
+                   (:unsigned-short ())
+                   (:int ())
+                   (:unsigned-int ())
+                   (:long ())
+                   (:unsigned-long ())
+                   (:long-long ())
+                   (:unsigned-long-long ())
+                   (:float ())
+                   (:double ())
+                   (id ()) (objc-class ()) (selector ())
+                   (:string ())
+                   (:unknown ()))))
+   ((ensure-same (parse-typespec "{Mulk=*{Untermulk={Unteruntermulk=}}i}")
+                 '(struct () "Mulk"
+                   (:string ())
+                   (struct () "Untermulk"
+                    (struct () "Unteruntermulk"))
+                   (:int ()))))))
+
+
 (deftestsuite data-coercion (objective-cl)
   ()
   (:equality-test #'objc-equal)
diff --git a/Lisp/type-conversion.lisp b/Lisp/type-conversion.lisp
index 858538b..05bb08e 100644
--- a/Lisp/type-conversion.lisp
+++ b/Lisp/type-conversion.lisp
@@ -78,6 +78,138 @@ and free the C string afterwards."
     (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))))
+                  (and qualifier
+                       (incf string-position)
+                       (push qualifier qualifiers))))
+    (values (case init-char
+              ((#\{ #\()
+               (let ((name-end (position #\= typestring :start start)))
+                 (list* (ecase init-char
+                          (#\{ 'struct)
+                          (#\( 'union))
+                        qualifiers
+                        (subseq typestring (1+ start) name-end)
+                        (progn
+                          (setq string-position (1+ name-end)) ; skip #\=
+                          (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