summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
Diffstat (limited to 'Lisp')
-rw-r--r--Lisp/class-definition.lisp3
-rw-r--r--Lisp/method-definition.lisp7
-rw-r--r--Lisp/method-invocation.lisp41
-rw-r--r--Lisp/tests.lisp169
-rw-r--r--Lisp/type-conversion-policy.lisp3
-rw-r--r--Lisp/type-conversion.lisp2
-rw-r--r--Lisp/type-handling.lisp116
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)))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 05:13:15 +0000