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

darcs-hash:b1e4d767b18dce617c5df6920ca592111604c2a6

1 files changed, 132 insertions, 0 deletions

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