From 65f8d8bf8e9a709e549917837f7c01a31aad3928 Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Wed, 19 Mar 2008 01:17:52 +0100 Subject: Make TYPESPEC a struct type. darcs-hash:e915984995e05d399993c4d602a7c4949053ca66 --- Lisp/class-definition.lisp | 3 +- Lisp/method-definition.lisp | 7 +- Lisp/method-invocation.lisp | 41 +++++----- Lisp/tests.lisp | 169 ++++++++++++++++++++------------------- Lisp/type-conversion-policy.lisp | 3 + Lisp/type-conversion.lisp | 2 +- Lisp/type-handling.lisp | 116 ++++++++++++++++++++------- 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))))) -- cgit v1.2.3