summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2007-09-16 02:58:32 +0200
committerMatthias Benkard <code@mail.matthias.benkard.de>2007-09-16 02:58:32 +0200
commit0996dc2fb30011a71b26b3f4845b6e76a0d56314 (patch)
tree2fdec7a7fd7ede35f6dbd2fd6869e1f9f79d4e9b /Lisp
parent1dfd60378e6ec47cef54bf0b63985247b971c88b (diff)
PRIMITIVE-INVOKE: More refactoring.
darcs-hash:1440c933de066bcb07053118d3472d18b63bf5a9
Diffstat (limited to 'Lisp')
-rw-r--r--Lisp/internal-utilities.lisp77
-rw-r--r--Lisp/method-invocation.lisp113
2 files changed, 127 insertions, 63 deletions
diff --git a/Lisp/internal-utilities.lisp b/Lisp/internal-utilities.lisp
new file mode 100644
index 0000000..818c18b
--- /dev/null
+++ b/Lisp/internal-utilities.lisp
@@ -0,0 +1,77 @@
+(in-package #:mulk.objective-cl)
+
+
+(defmacro atomically (&body body)
+ ;; Use a reentrant global lock here.
+ `(progn ,@body))
+
+
+(declaim (ftype (function (symbol * &rest *))))
+(defun apply-macro (macro-name arg &rest args)
+ "Because FOREIGN-FUNCALL is a macro. Why, oh why is this?"
+ (funcall
+ (compile nil
+ `(lambda ()
+ (,macro-name ,@(butlast (cons arg args))
+ ,@(car (last (cons arg args))))))))
+
+
+(defmacro with-foreign-conversion (bindings &body body)
+ `(with-obj-data-values
+ ,(mapcar #'(lambda (name-value-pair)
+ (destructuring-bind (name value)
+ name-value-pair
+ `(,name (lisp->obj-data ,value))))
+ bindings)
+ ,@body))
+
+
+(defmacro with-obj-data-values (bindings &body body)
+ `(let ,(mapcar #'(lambda (name-value-pair)
+ (destructuring-bind (name value)
+ name-value-pair
+ `(,name ,value)))
+ bindings)
+ (unwind-protect
+ (progn ,@body)
+ ,@(mapcar #'(lambda (name-value-pair)
+ `(dealloc-obj-data ,(first name-value-pair)))
+ bindings))))
+
+
+(defmacro with-foreign-string-pool ((register-fn-name) &body body)
+ (let ((pool-var (gensym)))
+ `(let ((,pool-var (list)))
+ (flet ((,register-fn-name (x)
+ (push x ,pool-var)
+ x))
+ (unwind-protect
+ (progn ,@body)
+ (dolist (x ,pool-var)
+ (cffi:foreign-string-free x)))))))
+
+
+(defmacro with-foreign-object-pool ((register-fn-name) &body body)
+ (let ((pool-var (gensym)))
+ `(let ((,pool-var (list)))
+ (flet ((,register-fn-name (x)
+ (push x ,pool-var)
+ x))
+ (unwind-protect
+ (progn ,@body)
+ (dolist (x ,pool-var)
+ (cffi:foreign-free x)))))))
+
+
+(defmacro defcoercion (to-class (object) &body body)
+ (let ((type-sym (gensym)))
+ `(defmethod coerce-object (,object (,type-sym (eql ',to-class)))
+ ,@body)))
+
+
+;; Compatibility with older versions of CFFI.
+(unless (fboundp 'foreign-funcall-pointer)
+ (defmacro foreign-funcall-pointer (pointer options &rest args)
+ (if (find-symbol "FOREIGN-FUNCALL-POINTER" '#:cffi)
+ `(cffi:foreign-funcall-pointer ,pointer ,options ,@args)
+ `(cffi:foreign-funcall (,pointer ,@options) ,@args))))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 820afd7..ec1913f 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -182,67 +182,55 @@ Returns: *result* --- the return value of the method invocation.
(defun primitive-invoke (receiver method-name return-type &rest args)
- (let ((return-c-type (case return-type
- ((id objc-class exception selector) :pointer)
- (otherwise return-type)))
- (selector (selector method-name))
- (temporary-foreign-objects (list))
- (temporary-foreign-strings (list)))
- (labels ((make-void-pointer-pointer (ptr)
- (cffi:foreign-alloc '(:pointer :void)
- :initial-element ptr))
- (register-temporary-object (object)
- (push object temporary-foreign-objects)
- object)
- (register-temporary-string (string)
- (push string temporary-foreign-strings)
- string)
- (alloc-pointer-and-register (target)
- (register-temporary-object
- (make-void-pointer-pointer target)))
- (alloc-string-and-register (string)
- (register-temporary-string
- (cffi:foreign-string-alloc string))))
- (cffi:with-foreign-objects ((arg-types '(:pointer :char) (length args))
- (objc-args '(:pointer :void) (+ (length args) 2))
- (return-value-cell return-c-type))
- (flet ((ad-hoc-arglist->objc-arglist! (args)
- (setf (cffi:mem-aref objc-args '(:pointer :void) 0)
- (alloc-pointer-and-register (pointer-to receiver))
- (cffi:mem-aref objc-args '(:pointer :void) 1)
- (alloc-pointer-and-register (pointer-to selector)))
- (loop for arg in args
- for i from 0
- do (let* ((type-name (lisp-value->type-name arg)))
- (setf (cffi:mem-aref objc-args
- '(:pointer :void)
- (+ i 2))
- (typecase arg
- #+(or)
- (c-pointer
- ;; Assume that arg points to a struct,
- ;; and that the method wants a copy of
- ;; that struct, not the pointer itself.
- arg)
- (string (alloc-pointer-and-register
- (alloc-string-and-register
- arg)))
- (t (alloc-pointer-and-register
- (typecase arg
- (c-pointer-wrapper (pointer-to arg))
- (t arg))))))
- (setf (cffi:mem-aref arg-types '(:pointer :char) i)
- (alloc-string-and-register
- (typecase arg
- #+(or) (c-pointer "{?=}")
- (t (type-name->type-id type-name))))))))
- (dealloc-registered-objects ()
- (dolist (x temporary-foreign-objects)
- (cffi:foreign-free x))
- (dolist (x temporary-foreign-strings)
- (cffi:foreign-string-free x))))
- (ad-hoc-arglist->objc-arglist! args)
- (unwind-protect
+ (with-foreign-string-pool (register-temporary-string)
+ (with-foreign-object-pool (register-temporary-object)
+ (let ((return-c-type (case return-type
+ ((id objc-class exception selector) :pointer)
+ (otherwise return-type)))
+ (selector (selector method-name)))
+ (labels ((make-void-pointer-pointer (ptr)
+ (cffi:foreign-alloc '(:pointer :void)
+ :initial-element ptr))
+ (alloc-pointer-and-register (target)
+ (register-temporary-object
+ (make-void-pointer-pointer target)))
+ (alloc-string-and-register (string)
+ (register-temporary-string
+ (cffi:foreign-string-alloc string))))
+ (cffi:with-foreign-objects ((arg-types '(:pointer :char) (length args))
+ (objc-args '(:pointer :void) (+ (length args) 2))
+ (return-value-cell return-c-type))
+ (flet ((ad-hoc-arglist->objc-arglist! (args)
+ (setf (cffi:mem-aref objc-args '(:pointer :void) 0)
+ (alloc-pointer-and-register (pointer-to receiver))
+ (cffi:mem-aref objc-args '(:pointer :void) 1)
+ (alloc-pointer-and-register (pointer-to selector)))
+ (loop for arg in args
+ for i from 0
+ do (let* ((type-name (lisp-value->type-name arg)))
+ (setf (cffi:mem-aref objc-args
+ '(:pointer :void)
+ (+ i 2))
+ (typecase arg
+ #+(or)
+ (c-pointer
+ ;; Assume that arg points to a struct,
+ ;; and that the method wants a copy of
+ ;; that struct, not the pointer itself.
+ arg)
+ (string (alloc-pointer-and-register
+ (alloc-string-and-register
+ arg)))
+ (t (alloc-pointer-and-register
+ (typecase arg
+ (c-pointer-wrapper (pointer-to arg))
+ (t arg))))))
+ (setf (cffi:mem-aref arg-types '(:pointer :char) i)
+ (alloc-string-and-register
+ (typecase arg
+ #+(or) (c-pointer "{?=}")
+ (t (type-name->type-id type-name)))))))))
+ (ad-hoc-arglist->objc-arglist! args)
(let* ((return-type-cell (alloc-string-and-register
(type-name->type-id return-type)))
(error-cell
@@ -262,8 +250,7 @@ Returns: *result* --- the return value of the method invocation.
:pointer (cffi:mem-ref return-value-cell
return-c-type))))
(otherwise (cffi:mem-ref return-value-cell
- return-c-type))))
- (dealloc-registered-objects)))))))
+ return-c-type)))))))))))
;;; (@* "Helper functions")