summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2007-09-16 18:34:04 +0200
committerMatthias Benkard <code@mail.matthias.benkard.de>2007-09-16 18:34:04 +0200
commit164950db293f283e5d1be7a9d6262ef1a331f359 (patch)
tree1e986f8022b74a7e18f0a34d2be9bcfbe6d54262 /Lisp
parent3cbca8870fcbbd8adbe7f5e580c7f0ae98086f8d (diff)
Add classes for tagged pointers.
darcs-hash:93dc7a7ee851ab3947332487b00b990143b81e46
Diffstat (limited to 'Lisp')
-rw-r--r--Lisp/data-types.lisp46
-rw-r--r--Lisp/defpackage.lisp4
-rw-r--r--Lisp/method-invocation.lisp1
-rw-r--r--Lisp/utilities.lisp50
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))