Added objc-letr and define-objc-function
Tue Oct 2 19:34:55 PDT 2007 matley@muppetslab.org
* Added objc-letr and define-objc-function
diff -rN -u old-cl-objc/src/lisp-interface.lisp new-cl-objc/src/lisp-interface.lisp
--- old-cl-objc/src/lisp-interface.lisp 2014-07-12 08:12:52.000000000 -0700
+++ new-cl-objc/src/lisp-interface.lisp 2014-07-12 08:12:53.000000000 -0700
@@ -317,6 +317,20 @@
`(let* ,(objc-let-bindings bindings)
,@body))
+(defmacro objc-letr (bindings &body body)
+ `(objc-let ,bindings
+ (prog1
+ (progn
+ ,@body)
+ ,@(mapcar (lambda (obj) `(invoke ,obj release)) (mapcar #'car bindings)))))
+
+(defmacro objc-letr* (bindings &body body)
+ `(objc-let* ,bindings
+ (prog1
+ (progn
+ ,@body)
+ ,@(mapcar (lambda (obj) `(invoke ,obj release)) (mapcar #'car bindings)))))
+
(defmacro with-object (obj &body actions)
"Calls messages with OBJ as receveir. ACTIONS is a list of
selector and arguments passed to invoke."
diff -rN -u old-cl-objc/src/packages.lisp new-cl-objc/src/packages.lisp
--- old-cl-objc/src/packages.lisp 2014-07-12 08:12:52.000000000 -0700
+++ new-cl-objc/src/packages.lisp 2014-07-12 08:12:53.000000000 -0700
@@ -22,6 +22,7 @@
"FRAMEWORK-DEFINITIONS-PATHNAME"
"DEFINE-OBJC-STRUCT"
+ "DEFINE-OBJC-FUNCTION"
"OBJC-STRUCT-SLOT-VALUE"
"OBJC-ID"
@@ -96,6 +97,8 @@
"WITH-IVAR-ACCESSORS"
"OBJC-LET"
"OBJC-LET*"
+ "OBJC-LETR"
+ "OBJC-LETR*"
"WITH-OBJECT"
"*ACRONYMS*"
diff -rN -u old-cl-objc/src/structs.lisp new-cl-objc/src/structs.lisp
--- old-cl-objc/src/structs.lisp 2014-07-12 08:12:52.000000000 -0700
+++ new-cl-objc/src/structs.lisp 2014-07-12 08:12:53.000000000 -0700
@@ -125,6 +125,68 @@
(let ((objc-name (car (find lisp-name *registered-structs* :key #'cdr :test #'string-equal))))
(find objc-name *objc-struct-db* :key #'second :test #'string-equal)))
+(defmacro define-objc-function (name-and-options return-type &rest doc-and-args)
+ (let* ((doc-string)
+ (args (if (stringp (car doc-and-args))
+ (progn
+ (setf doc-string (car doc-and-args))
+ (cdr doc-and-args))
+ doc-and-args))
+ (has-struct-arg (member-if #'find-struct-definition args :key #'second))
+ (has-struct-return (find-struct-definition return-type))
+ (splayed-args (loop
+ for arg-def in args
+ for name = (symbol-name (first arg-def))
+ for type = (second arg-def)
+ for struct-def = (find-struct-definition type)
+ when (not struct-def) nconc (list arg-def)
+ when struct-def nconc (loop
+ for i below (ceiling (objc-foreign-type-size type)
+ (foreign-type-size :int))
+ for arg = (intern (format nil "~a-~d" name i))
+ collecting (list arg :int))))
+ (dereferenced-args (loop
+ for arg-def in args
+ for name = (car arg-def)
+ for type = (cadr arg-def)
+ for struct-def = (find-struct-definition type)
+ when struct-def nconc (loop
+ for i below (ceiling (objc-foreign-type-size type)
+ (foreign-type-size :int))
+ collect `(mem-aref ,name :int ,i))
+ when (not struct-def) nconc (list name)))
+ (lisp-args (mapcar #'car args)))
+ (if has-struct-arg
+ (multiple-value-bind (lisp-name foreign-name)
+ (cffi::parse-name-and-options name-and-options)
+ (let* ((new-name (intern (format nil "SPLAYED-~a" lisp-name)))
+ (stret (gensym "STRET-"))
+ (stret-val (gensym))
+ (new-name-and-options (list foreign-name new-name)))
+ `(progn
+ ,(cond
+ ((not has-struct-return)
+ `(cffi:defcfun ,new-name-and-options ,return-type ,@splayed-args))
+ ((small-struct-type-p has-struct-return)
+ `(cffi:defcfun ,new-name-and-options :int ,@splayed-args))
+ ((big-struct-type-p has-struct-return)
+ `(cffi:defcfun ,new-name-and-options :void (,stret :pointer) ,@splayed-args))
+ (t (error "Struct nor small neither big?That shouldn't happen")))
+ (defun ,lisp-name ,lisp-args
+ ,doc-string
+ ,(cond
+ ((not has-struct-return)
+ `(,new-name ,@dereferenced-args))
+ ((small-struct-type-p has-struct-return)
+ `(let ((,stret-val (cffi:foreign-alloc ,return-type)))
+ (setf (mem-ref ,stret-val :int) (,new-name ,@dereferenced-args))
+ ,stret-val))
+ ((big-struct-type-p has-struct-return)
+ `(let ((,stret-val (cffi:foreign-alloc ,return-type)))
+ (,new-name ,stret-val ,@dereferenced-args)))
+ (t (error "Struct nor small neither big?That shouldn't happen")))))))
+ `(cffi:defcfun ,name-and-options ,return-type ,@doc-and-args))))
+
(defmacro define-objc-struct (name-and-objc-options &body doc-and-slots)
"Wrapper for CFFI:DEFCSTRUCT allowing struct to be used as
type. DOC-AND-SLOTS will be passed directly to CFFI:DEFCSTRUCT