summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2008-02-17 12:41:52 +0100
committerMatthias Benkard <code@mail.matthias.benkard.de>2008-02-17 12:41:52 +0100
commit0c4aa479a72e2c41f775b5874e6d14b986a3c8a8 (patch)
treef13e2fbb99caf7cfbc8d62148bde48b646128bdf
parent9518f18560285cbeb66269a0cd88e7ff6146aee9 (diff)
Improve the WITH-FOREIGN-STRING-POOL macro.
darcs-hash:368ae035198c23f02565826576535eca63088985
-rw-r--r--Lisp/internal-utilities.lisp12
-rw-r--r--Lisp/method-invocation.lisp293
2 files changed, 153 insertions, 152 deletions
diff --git a/Lisp/internal-utilities.lisp b/Lisp/internal-utilities.lisp
index 92b003b..b23905f 100644
--- a/Lisp/internal-utilities.lisp
+++ b/Lisp/internal-utilities.lisp
@@ -50,12 +50,16 @@
(member symbol *features*))
-(defmacro with-foreign-string-pool ((register-fn-name) &body body)
+(defmacro with-foreign-string-pool ((register-fn-name
+ allocate-fn-name) &body body)
(let ((pool-var (gensym)))
`(let ((,pool-var (list)))
- (flet ((,register-fn-name (x)
- (push x ,pool-var)
- x))
+ (labels ((,register-fn-name (x)
+ (push x ,pool-var)
+ x)
+ (,allocate-fn-name (string)
+ (,register-fn-name
+ (cffi:foreign-string-alloc string))))
(unwind-protect
(progn ,@body)
(dolist (x ,pool-var)
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 660b9ae..72abefd 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -324,154 +324,151 @@ easier to use with __apply__.
arg-typestrings arg-types argc args)
(let ((return-c-type (typespec->c-type return-type))
(arg-c-types (mapcar #'typespec->c-type arg-types)))
- (with-foreign-string-pool (register-temporary-string)
- (flet ((alloc-string-and-register (string)
- (register-temporary-string
- (cffi:foreign-string-alloc string))))
- (cffi:with-foreign-objects ((objc-arg-typestrings :string
- (- argc 2))
- (objc-arg-ptrs :pointer argc)
- (objc-return-value-cell
- ;; Note that this cell is not used
- ;; if the method returns a struct,
- ;; array or union. For these, see
- ;; OBJC-STRUCT-RETURN-VALUE-CELL
- ;; below.
- (if (eq return-c-type :void)
- :int
- return-c-type))
- (objc-arg-buffer +pessimistic-allocation-type+
- argc))
- ;; Prepare the argument pointer vector.
- (loop for i from 0 below argc
- do (setf (cffi:mem-aref objc-arg-ptrs :pointer i)
- (cffi:inc-pointer objc-arg-buffer
- (* i +pessimistic-allocation-size+))))
- ;; Prepare the argument typestring vector. Note that we don't
- ;; pass the first two strings, as they are always the same.
- (loop for i from 0
- for arg-typestring in (cddr arg-typestrings)
- do (setf (mem-aref objc-arg-typestrings :string i)
- (alloc-string-and-register arg-typestring)))
- (macrolet ((argref (type num)
- `(cffi:mem-ref objc-arg-buffer ,type
- (* ,num +pessimistic-allocation-size+))))
- ;; Prepare the arguments.
- (setf (argref :pointer 0) (if (pointerp receiver)
- receiver
- (pointer-to receiver)))
- (setf (argref :pointer 1) (if (pointerp selector)
- selector
- (pointer-to selector)))
- (loop for i from 2
- for arg in args
- for arg-type in (cddr arg-types) ;skip the first two arguments
- for arg-c-type in (cddr arg-c-types) ;likewise
- do (case (car arg-type)
- ((:pointer)
- (setf (argref :pointer i) arg))
- ((objective-c-class exception)
- (setf (argref :pointer i) (pointer-to arg)))
- ((selector)
- (setf (argref :pointer i) (pointer-to (selector arg))))
- ((:string)
- (setf (argref :string i)
- (alloc-string-and-register arg)))
- ((struct union)
- ;; This is not very sophisticated, but, at
- ;; present, we don't care about the internals of
- ;; structs and unions much. Functions returning
- ;; structs actually just give us pointers to them,
- ;; so we just put those pointers back into the
- ;; functions as arguments.
- ;;
- ;; Note that the target type is a struct/union,
- ;; not a pointer. This means that we actually
- ;; have to pass a struct/union as an argument. We
- ;; therefore ignore the memory space reserved for
- ;; argument cells in the argument buffer and
- ;; simply set the argument pointer directly.
- (setf (cffi:mem-aref objc-arg-ptrs :pointer i)
- arg))
- ((array)
- ;; This, too, might someday be ripped out and
- ;; replaced with something more flexible. For
- ;; now, it's the same as for structs and unions.
- ;; That's the nice thing about opaque C data
- ;; structures: As a binding writer, we just pass
- ;; them around without caring about their
- ;; structure.
- (setf (cffi:mem-aref objc-arg-ptrs :pointer i)
- arg))
- ((id)
- ;; This case is actually interesting. We can do a
- ;; lot of automatic conversion between different
- ;; kinds of stuff. The conversion rules are
- ;; somewhat arbitrary, but in the absence of more
- ;; detailed method signature type information,
- ;; it's the best we can do.
- (setf (argref arg-c-type i)
- (pointer-to (coerce-object arg 'id))))
- (t (setf (argref arg-c-type i)
- (case arg
- ;; Do the right thing for booleans.
- ;;
- ;; Note that Objective-C method
- ;; invocations do not understand
- ;; generalised booleans. Among other
- ;; things, this means that passing 0
- ;; for a boolean is the same as
- ;; passing NIL, not the same as
- ;; passing T.
- ((nil) 0)
- ((t) 1)
- (otherwise arg)))))))
- (let* ((objc-struct-return-value-cell
- (if (member (typespec-primary-type return-type)
- '(struct union array))
- ;; Note that sizeof(char) is defined to be 1. That
- ;; is, sizeof returns a size in units of chars, not
- ;; in units of bytes.
- (foreign-alloc :char :count (%objcl-sizeof-type
- return-typestring))
- nil))
- (error-cell
- (%objcl-invoke-with-types (- argc 2)
- superclass-pointer-for-send-super
- return-typestring
- objc-arg-typestrings
- (or objc-struct-return-value-cell
- objc-return-value-cell)
- objc-arg-ptrs)))
- (unless (cffi:null-pointer-p error-cell)
- (error (make-condition 'exception :pointer error-cell)))
- (case (or (typespec-nominal-type return-type)
- (typespec-primary-type return-type))
- ((id objective-c-class exception selector)
- (let ((*skip-retaining*
- (or *skip-retaining*
- (constructor-name-p (selector-name selector)))))
- (intern-pointer-wrapper (car return-type)
- :pointer (cffi:mem-ref
- objc-return-value-cell
- return-c-type))))
- ((:char :unsigned-char)
- ;; FIXME? This is non-trivial. See policy.lisp for
- ;; details.
- (objc-char->lisp-value (cffi:mem-ref objc-return-value-cell
- return-c-type)
- receiver
- selector))
- ((struct union array)
- ;; The caller is responsible for preventing the return
- ;; value from being garbage-collected by setting
- ;; FOREIGN-VALUE-LISP-MANAGED-P to false.
- (make-struct-wrapper objc-struct-return-value-cell
- return-type
- t))
- ((:void) (values))
- (otherwise (cffi:mem-ref objc-return-value-cell
- return-c-type)))))))))
+ (with-foreign-string-pool (register-temporary-string
+ allocate-string-and-register)
+ (cffi:with-foreign-objects ((objc-arg-typestrings :string
+ (- argc 2))
+ (objc-arg-ptrs :pointer argc)
+ (objc-return-value-cell
+ ;; Note that this cell is not used if
+ ;; the method returns a struct, array
+ ;; or union. For these, see
+ ;; OBJC-STRUCT-RETURN-VALUE-CELL
+ ;; below.
+ (if (eq return-c-type :void)
+ :int
+ return-c-type))
+ (objc-arg-buffer +pessimistic-allocation-type+
+ argc))
+ ;; Prepare the argument pointer vector.
+ (loop for i from 0 below argc
+ do (setf (cffi:mem-aref objc-arg-ptrs :pointer i)
+ (cffi:inc-pointer objc-arg-buffer
+ (* i +pessimistic-allocation-size+))))
+ ;; Prepare the argument typestring vector. Note that we don't
+ ;; pass the first two strings, as they are always the same.
+ (loop for i from 0
+ for arg-typestring in (cddr arg-typestrings)
+ do (setf (mem-aref objc-arg-typestrings :string i)
+ (allocate-string-and-register arg-typestring)))
+ (macrolet ((argref (type num)
+ `(cffi:mem-ref objc-arg-buffer ,type
+ (* ,num +pessimistic-allocation-size+))))
+ ;; Prepare the arguments.
+ (setf (argref :pointer 0) (if (pointerp receiver)
+ receiver
+ (pointer-to receiver)))
+ (setf (argref :pointer 1) (if (pointerp selector)
+ selector
+ (pointer-to selector)))
+ (loop for i from 2
+ for arg in args
+ for arg-type in (cddr arg-types) ;skip the first two arguments
+ for arg-c-type in (cddr arg-c-types) ;likewise
+ do (case (car arg-type)
+ ((:pointer)
+ (setf (argref :pointer i) arg))
+ ((objective-c-class exception)
+ (setf (argref :pointer i) (pointer-to arg)))
+ ((selector)
+ (setf (argref :pointer i) (pointer-to (selector arg))))
+ ((:string)
+ (setf (argref :string i)
+ (allocate-string-and-register arg)))
+ ((struct union)
+ ;; This is not very sophisticated, but, at
+ ;; present, we don't care about the internals of
+ ;; structs and unions much. Functions returning
+ ;; structs actually just give us pointers to them,
+ ;; so we just put those pointers back into the
+ ;; functions as arguments.
+ ;;
+ ;; Note that the target type is a struct/union,
+ ;; not a pointer. This means that we actually
+ ;; have to pass a struct/union as an argument. We
+ ;; therefore ignore the memory space reserved for
+ ;; argument cells in the argument buffer and
+ ;; simply set the argument pointer directly.
+ (setf (cffi:mem-aref objc-arg-ptrs :pointer i)
+ arg))
+ ((array)
+ ;; This, too, might someday be ripped out and
+ ;; replaced with something more flexible. For
+ ;; now, it's the same as for structs and unions.
+ ;; That's the nice thing about opaque C data
+ ;; structures: As a binding writer, we just pass
+ ;; them around without caring about their
+ ;; structure.
+ (setf (cffi:mem-aref objc-arg-ptrs :pointer i)
+ arg))
+ ((id)
+ ;; This case is actually interesting. We can do a
+ ;; lot of automatic conversion between different
+ ;; kinds of stuff. The conversion rules are
+ ;; somewhat arbitrary, but in the absence of more
+ ;; detailed method signature type information,
+ ;; it's the best we can do.
+ (setf (argref arg-c-type i)
+ (pointer-to (coerce-object arg 'id))))
+ (t (setf (argref arg-c-type i)
+ (case arg
+ ;; Do the right thing for booleans.
+ ;;
+ ;; Note that Objective-C method
+ ;; invocations do not understand
+ ;; generalised booleans. Among other
+ ;; things, this means that passing 0 for
+ ;; a boolean is the same as passing NIL,
+ ;; not the same as passing T.
+ ((nil) 0)
+ ((t) 1)
+ (otherwise arg)))))))
+ (let* ((objc-struct-return-value-cell
+ (if (member (typespec-primary-type return-type)
+ '(struct union array))
+ ;; Note that sizeof(char) is defined to be 1. That
+ ;; is, sizeof returns a size in units of chars, not
+ ;; in units of bytes.
+ (foreign-alloc :char :count (%objcl-sizeof-type
+ return-typestring))
+ nil))
+ (error-cell
+ (%objcl-invoke-with-types (- argc 2)
+ superclass-pointer-for-send-super
+ return-typestring
+ objc-arg-typestrings
+ (or objc-struct-return-value-cell
+ objc-return-value-cell)
+ objc-arg-ptrs)))
+ (unless (cffi:null-pointer-p error-cell)
+ (error (make-condition 'exception :pointer error-cell)))
+ (case (or (typespec-nominal-type return-type)
+ (typespec-primary-type return-type))
+ ((id objective-c-class exception selector)
+ (let ((*skip-retaining*
+ (or *skip-retaining*
+ (constructor-name-p (selector-name selector)))))
+ (intern-pointer-wrapper (car return-type)
+ :pointer (cffi:mem-ref
+ objc-return-value-cell
+ return-c-type))))
+ ((:char :unsigned-char)
+ ;; FIXME? This is non-trivial. See policy.lisp for
+ ;; details.
+ (objc-char->lisp-value (cffi:mem-ref objc-return-value-cell
+ return-c-type)
+ receiver
+ selector))
+ ((struct union array)
+ ;; The caller is responsible for preventing the return
+ ;; value from being garbage-collected by setting
+ ;; FOREIGN-VALUE-LISP-MANAGED-P to false.
+ (make-struct-wrapper objc-struct-return-value-cell
+ return-type
+ t))
+ ((:void) (values))
+ (otherwise (cffi:mem-ref objc-return-value-cell
+ return-c-type))))))))
;;; (@* "Helper functions")