summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Lisp/constant-data.lisp16
-rw-r--r--Lisp/data-types.lisp4
-rw-r--r--Lisp/libobjcl.lisp6
-rw-r--r--Lisp/method-invocation.lisp106
-rw-r--r--objective-cl.asd1
5 files changed, 81 insertions, 52 deletions
diff --git a/Lisp/constant-data.lisp b/Lisp/constant-data.lisp
index efda456..f936908 100644
--- a/Lisp/constant-data.lisp
+++ b/Lisp/constant-data.lisp
@@ -1,6 +1,22 @@
(in-package #:mulk.objective-cl)
+;;;; (@* "Allocation Parameters")
+(defconstant +pessimistic-allocation-type+
+ (loop with max-c-type = :char
+ for c-type in '(:pointer :int :long :float :double
+ #-cffi-features:no-long-long :long-long
+ #-cffi-features:no-long-long :unsigned-long-long
+ :unsigned-char :unsigned-int :unsigned-long
+ :short :unsigned-short)
+ when (> (cffi:foreign-type-size c-type)
+ (cffi:foreign-type-size max-c-type))
+ do (progn (setq max-c-type c-type))
+ finally (return max-c-type)))
+
+(defconstant +pessimistic-allocation-size+
+ (cffi:foreign-type-size +pessimistic-allocation-type+))
+
;;;; (@* "The constant data")
;;; Copied from objc-api.h
;;; Probably ought to be generated by C code at initialisation time.
diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp
index 1095e38..25bbc21 100644
--- a/Lisp/data-types.lisp
+++ b/Lisp/data-types.lisp
@@ -218,3 +218,7 @@ an __exception__, you can simply send it the `self' message.
;;;; (@* "Convenience types")
(deftype c-pointer ()
'(satisfies pointerp))
+
+
+(deftype argument-number ()
+ `(integer 0 ,call-arguments-limit))
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index 978bcfe..ffe166f 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -34,10 +34,10 @@
(defcfun ("objcl_invoke_with_types" %objcl-invoke-with-types) :pointer
(argc :int)
- (return_typespec (:pointer :char))
- (arg_typespecs (:pointer (:pointer :char)))
+ (return_typespec :string)
+ (arg_typespecs (:array :string))
(return_value (:pointer :void))
- (argv (:pointer (:pointer :void))))
+ (argv (:array (:pointer :void))))
(defcfun ("objcl_find_class" %objcl-find-class) :pointer
(class-name :string))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 826cc29..05b1eab 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -184,67 +184,75 @@ 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
- ((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))
+ (let* ((raw-argc (the argument-number (length args)))
+ (real-argc (+ raw-argc 2))
+ (return-c-type (case return-type
+ ((id objc-class exception selector) :pointer)
+ (otherwise return-type)))
+ (selector (selector method-name)))
+ (labels ((alloc-string-and-register (string)
+ (register-temporary-string
+ (cffi:foreign-string-alloc string))))
+ ;; We allocate a conservatively-sized buffer for arguments of
+ ;; primitive types called OBJC-ARG-BUFFER. Non-primitive types
+ ;; don't need allocation, anyway, because we can just pass the
+ ;; pointer directly. It's unfortunate that we can't do this for
+ ;; `id' values, because we can't just pass a pointer to the `id'
+ ;; SAP (which would be highly implementation-dependent and might
+ ;; even change at any time, especially during GC).
+ ;;
+ ;; In any case, OBJC-ARGS-PTRS is the array of pointers which
+ ;; the libffi docs call AVALUES. It must therefore contain
+ ;; pointers pointing into the argument buffer (or, in the case
+ ;; of a newly allocated C string, to that string). This is what
+ ;; the DOTIMES form below tries to ensure.
+ (cffi:with-foreign-objects ((arg-types '(:pointer :char)
+ (the fixnum (length args)))
+ (objc-arg-ptrs '(:pointer :void)
+ real-argc)
+ (return-value-cell return-c-type)
+ (objc-arg-buffer +pessimistic-allocation-type+
+ real-argc))
+ (dotimes (i real-argc)
+ (setf (cffi:mem-aref objc-arg-ptrs '(:pointer :void) i)
+ (cffi:inc-pointer objc-arg-buffer
+ (* i +pessimistic-allocation-size+))))
+ (macrolet ((argref (type num)
+ `(cffi:mem-ref objc-arg-buffer ,type
+ (* ,num +pessimistic-allocation-size+))))
(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)))
+ (setf (argref '(:pointer :void) 0)
+ (pointer-to receiver)
+ (argref '(:pointer :void) 1)
+ (pointer-to selector))
(loop for arg in args
- for i from 0
+ for i from 0 to raw-argc
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)))
- ((or c-pointer-wrapper
- c-pointer)
- (alloc-pointer-and-register
- (typecase arg
- (c-pointer-wrapper (pointer-to arg))
- (t arg))))
- (t (cffi:foreign-alloc (type-name->c-type
- type-name)
- :initial-element arg))))
+ (typecase arg
+ ((or c-pointer-wrapper
+ c-pointer)
+ (setf (argref :pointer (+ i 2))
+ (typecase arg
+ (c-pointer-wrapper (pointer-to arg))
+ (t arg))))
+ (string
+ (setf (argref :string (+ i 2))
+ (alloc-string-and-register arg)))
+ (t (setf (argref (type-name->c-type type-name)
+ (+ i 2))
+ 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)))))))))
+ (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
- (%objcl-invoke-with-types (length args)
+ (%objcl-invoke-with-types raw-argc
return-type-cell
arg-types
return-value-cell
- objc-args)))
+ objc-arg-ptrs)))
(unless (cffi:null-pointer-p error-cell)
(error (make-instance 'exception :pointer error-cell)))
(case return-type
diff --git a/objective-cl.asd b/objective-cl.asd
index 66f45c0..c936614 100644
--- a/objective-cl.asd
+++ b/objective-cl.asd
@@ -22,6 +22,7 @@
(:file "init" :depends-on ("libobjcl"))
(:file "method-invocation" :depends-on ("defpackage"
"name-conversion"
+ "data-types"
"libobjcl"
"internal-utilities"
"parameters"))
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-15 17:10:20 +0000