diff options
| -rw-r--r-- | Lisp/tests.lisp | 64 | ||||
| -rw-r--r-- | Lisp/type-conversion.lisp | 132 |
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 |