diff options
| -rw-r--r-- | Lisp/data-types.lisp | 46 | ||||
| -rw-r--r-- | Lisp/defpackage.lisp | 4 | ||||
| -rw-r--r-- | Lisp/method-invocation.lisp | 1 | ||||
| -rw-r--r-- | Lisp/utilities.lisp | 50 |
4 files changed, 101 insertions, 0 deletions
diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp index c757070..1095e38 100644 --- a/Lisp/data-types.lisp +++ b/Lisp/data-types.lisp @@ -154,6 +154,52 @@ an __exception__, you can simply send it the `self' message. __id__")) +(defclass opaque-struct (c-pointer-wrapper) + ((name :type (or null string) + :accessor struct-name + :initarg :name))) + +(defclass tagged-struct (c-pointer-wrapper) + ((name :type (or null string) + :accessor struct-name + :initarg :name) + (children :type list + :accessor struct-children + :initarg :children))) + +(defclass opaque-union (c-pointer-wrapper) + ((name :type (or null string) + :accessor struct-name + :initarg :name))) + +(defclass tagged-union (c-pointer-wrapper) + ((name :type (or null string) + :accessor struct-name + :initarg :name) + (children :type list + :accessor struct-children + :initarg :children))) + +(defclass tagged-array (c-pointer-wrapper) + ((element-type :type symbol + :accessor tagged-array-element-type + :initarg :element-type))) + + +(defgeneric type-info (thing)) + +(defmethod type-info ((thing opaque-struct)) + (with-slots (name) + thing + (list* 'struct '(opaque) name))) + +(defmethod type-info ((thing tagged-struct)) + (with-slots (name children) + thing + (list* 'struct '() name (mapcar #'type-info children)))) + + + (defgeneric objcl-eql (obj1 obj2)) (defmethod objcl-eql ((obj1 c-pointer-wrapper) (obj2 c-pointer-wrapper)) (pointer-eq (pointer-to obj1) (pointer-to obj2))) diff --git a/Lisp/defpackage.lisp b/Lisp/defpackage.lisp index 46114d5..bdf1eed 100644 --- a/Lisp/defpackage.lisp +++ b/Lisp/defpackage.lisp @@ -17,6 +17,10 @@ #:objc-eql #:objc-equal + ;; Macros + #:define-objc-struct + #:define-objc-union + ;; Special variables #:*trace-method-calls* diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp index a9e9336..826cc29 100644 --- a/Lisp/method-invocation.lisp +++ b/Lisp/method-invocation.lisp @@ -182,6 +182,7 @@ Returns: *result* --- the return value of the method invocation. (defun primitive-invoke (receiver method-name return-type &rest args) + "An invocation mechanism with ad-hoc argument conversion." (with-foreign-string-pool (register-temporary-string) (with-foreign-object-pool (register-temporary-object) (let ((return-c-type (case return-type diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp index 405cacf..2e8839c 100644 --- a/Lisp/utilities.lisp +++ b/Lisp/utilities.lisp @@ -124,3 +124,53 @@ (primitive-invoke (primitive-invoke exception "name" 'id) "UTF8String" :string) (primitive-invoke exception "hash" :unsigned-int)))) + + +;;; (@* "Structure and Union Definition") +(defun make-objc-struct/union-definer (type name-and-options c-names + doc-and-slots) + (let ((struct-name (ctypecase name-and-options + (list (first name-and-options)) + (symbol name-and-options))) + (slots (typecase (first doc-and-slots) + (string (rest doc-and-slots)) + (t doc-and-slots)))) + `(progn + ,(if (eq type :struct) + `(defcstruct ,name-and-options ,@doc-and-slots) + `(defcunion ,name-and-options ,@doc-and-slots)) + ,@(mapcar #'(lambda (slot) + (let ((slot-name (first slot))) + `(defun ,(intern (concatenate 'string + (symbol-name struct-name) + "-" + (symbol-name slot-name)) + (symbol-package slot-name)) + (struct) + (check-type struct ,(if (eq type :struct) + `(or c-pointer + opaque-struct + tagged-struct) + `(or c-pointer + opaque-union + tagged-union))) + (when (typep struct ,(if (eq type :struct) + `'tagged-struct + `'tagged-union)) + (assert (member (struct-name struct) + ',c-names + :test #'string=))) + (cffi:foreign-slot-value struct + ',struct-name + ',slot-name)))) + slots)))) + +(defmacro define-objc-struct (name-and-options c-names &rest doc-and-slots) + "Like CFFI:DEFCSTRUCT except that it provides accessors that check +their arguments according to their struct names." + (make-objc-struct/union-definer :struct name-and-options c-names doc-and-slots)) + +(defmacro define-objc-union (name-and-options c-names &rest doc-and-slots) + "Like CFFI:DEFCUNION except that it provides accessors that check +their arguments according to their struct names." + (make-objc-struct/union-definer :union name-and-options c-names doc-and-slots)) |