diff options
| -rw-r--r-- | Lisp/internal-utilities.lisp | 77 | ||||
| -rw-r--r-- | Lisp/method-invocation.lisp | 113 |
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") |