summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Lisp/tests.lisp64
-rw-r--r--Lisp/type-conversion.lisp132
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