From a989ea1318574332c31cc48defdbd01f88d74461 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Sun, 16 Sep 2007 02:02:51 +0200
Subject: PRIMITIVE-INVOKE: Fix a bunch of memory access bugs.
darcs-hash:36acfdc03f4004a971aa31a81b87e40c52940f82
---
Lisp/memory-management.lisp | 4 +-
Lisp/method-invocation.lisp | 145 +++++++++++++++++++++++---------------------
Lisp/tests.lisp | 2 +-
3 files changed, 79 insertions(+), 72 deletions(-)
(limited to 'Lisp')
diff --git a/Lisp/memory-management.lisp b/Lisp/memory-management.lisp
index 849e9d0..de75626 100644
--- a/Lisp/memory-management.lisp
+++ b/Lisp/memory-management.lisp
@@ -30,7 +30,7 @@
:incomplete)
(let ((new-obj (call-next-method)))
(unless *skip-retaining*
- (unsafe-primitive-invoke new-obj "retain" id))
+ (primitive-invoke new-obj "retain" 'id))
(unless *skip-finalization*
;; We only put the new object into the hash
;; table if it is a regular wrapper object
@@ -56,7 +56,7 @@
(*skip-retaining* t))
(make-instance saved-type
:pointer saved-pointer))))
- (unsafe-primitive-invoke temp "release" id))))
+ (primitive-invoke temp "release" :void))))
(trivial-garbage:finalize new-obj #'finalizer))))
new-obj))
(t obj))))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 41584ad..dbdde6c 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -148,7 +148,7 @@ Returns: *result* --- the return value of the method invocation.
(defmacro unsafe-primitive-invoke (receiver method-name return-type &rest args)
- (let ((real-return-type (if (member return-type '(id class exception))
+ (let ((real-return-type (if (member return-type '(id objc-class exception))
:pointer
return-type))
(real-receiver (gensym))
@@ -169,12 +169,12 @@ Returns: *result* --- the return value of the method invocation.
(list :pointer (pointer-to ,real-selector))
objc-arglist
(list ,real-return-type)))))
- ,(if (member return-type '(id class exception))
+ ,(if (member return-type '(id objc-class exception))
`(let (,@(when (constructor-name-p (selector-name selector))
`((*skip-retaining* t))))
(make-instance ',(case return-type
((id) 'id)
- ((class) 'objc-class)
+ ((objc-class) 'objc-class)
((exception) 'exception))
:pointer return-value))
`return-value))
@@ -182,73 +182,80 @@ 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 class exception selector) :pointer)
- (otherwise return-type)))
- (return-type-cell (cffi:foreign-string-alloc
- (type-name->type-id return-type)))
- (selector (selector method-name)))
- (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)
- (pointer-to receiver)
- (cffi:mem-aref objc-args '(:pointer :void) 1)
- (pointer-to selector))
- (loop for arg in args
- for i from 2
- do (let* ((type-name (lisp-value->type-name arg))
- #+(or)
- (cffi-type (type-name->lisp-type type-name)))
- (setf (cffi:mem-aref objc-args '(:pointer :void) i)
- (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)
- (t (cffi:foreign-alloc
- #+(or) cffi-type
- :pointer
- :initial-element (typecase arg
- (c-pointer-wrapper
- (print (pointer-to arg)))
- (t arg))))))
- (setf (cffi:mem-aref arg-types '(:pointer :char) i)
- (cffi:foreign-string-alloc
- (typecase arg
- #+(or) (c-pointer "{?=}")
- (t (type-name->type-id type-name))))))))
- (dealloc-ad-hoc-objc-arglist ()
- (dotimes (i (length args))
+ (flet ((make-void-pointer-pointer (ptr)
+ (cffi:foreign-alloc #+(or) cffi-type
+ '(:pointer :void)
+ :initial-element ptr)))
+ (let ((return-c-type (case return-type
+ ((id objc-class exception selector) :pointer)
+ (otherwise return-type)))
+ (return-type-cell (cffi:foreign-string-alloc
+ (type-name->type-id return-type)))
+ (selector (selector method-name)))
+ (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)
+ (make-void-pointer-pointer (pointer-to receiver))
+ (cffi:mem-aref objc-args '(:pointer :void) 1)
+ (make-void-pointer-pointer (pointer-to selector)))
+ (loop for arg in args
+ for i from 0
+ do (let* ((type-name (lisp-value->type-name arg))
+ #+(or)
+ (cffi-type (type-name->lisp-type type-name)))
+ (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)
+ (t (make-void-pointer-pointer
+ (typecase arg
+ (c-pointer-wrapper (pointer-to arg))
+ (t arg))))))
+ (setf (cffi:mem-aref arg-types '(:pointer :char) i)
+ (cffi:foreign-string-alloc
+ (typecase arg
+ #+(or) (c-pointer "{?=}")
+ (t (type-name->type-id type-name))))))))
+ (dealloc-ad-hoc-objc-arglist ()
+ (cffi:foreign-free
+ (cffi:mem-aref objc-args '(:pointer :void) 0))
(cffi:foreign-free
- (cffi:mem-aref objc-args '(:pointer :void) (+ i 2)))
- (cffi:foreign-string-free
- (cffi:mem-aref arg-types '(:pointer :char) i)))))
- (ad-hoc-arglist->objc-arglist! args)
- (unwind-protect
- (let ((error-cell
- (%objcl-invoke-with-types (length args)
- return-type-cell
- arg-types
- return-value-cell
- objc-args)))
- (unless (cffi:null-pointer-p error-cell)
- (error (make-instance 'exception :pointer error-cell)))
- (case return-type
- ((id class exception selector)
- (let ((*skip-retaining*
- (or *skip-retaining*
- (constructor-name-p (selector-name selector)))))
- (make-instance return-type
- :pointer (cffi:mem-ref return-value-cell
- return-c-type))))
- (otherwise (cffi:mem-ref return-value-cell
- return-c-type))))
- (dealloc-ad-hoc-objc-arglist)
- (foreign-string-free return-type-cell))))))
+ (cffi:mem-aref objc-args '(:pointer :void) 1))
+ (dotimes (i (length args))
+ (cffi:foreign-free
+ (cffi:mem-aref objc-args '(:pointer :void) (+ i 2)))
+ (cffi:foreign-string-free
+ (cffi:mem-aref arg-types '(:pointer :char) i)))))
+ (ad-hoc-arglist->objc-arglist! args)
+ (unwind-protect
+ (let ((error-cell
+ (%objcl-invoke-with-types (length args)
+ return-type-cell
+ arg-types
+ return-value-cell
+ objc-args)))
+ (unless (cffi:null-pointer-p error-cell)
+ (error (make-instance 'exception :pointer error-cell)))
+ (case return-type
+ ((id objc-class exception selector)
+ (let ((*skip-retaining*
+ (or *skip-retaining*
+ (constructor-name-p (selector-name selector)))))
+ (make-instance return-type
+ :pointer (cffi:mem-ref return-value-cell
+ return-c-type))))
+ (otherwise (cffi:mem-ref return-value-cell
+ return-c-type))))
+ (dealloc-ad-hoc-objc-arglist)
+ (foreign-string-free return-type-cell)))))))
;;; (@* "Helper functions")
diff --git a/Lisp/tests.lisp b/Lisp/tests.lisp
index 855860a..90e1fcf 100644
--- a/Lisp/tests.lisp
+++ b/Lisp/tests.lisp
@@ -60,7 +60,7 @@
((ensure-same (primitive-invoke (find-objc-class 'ns-object)
'self 'id)
(primitive-invoke (find-objc-class 'ns-object)
- 'class 'class)))
+ 'class 'objc-class)))
((ensure-different (primitive-invoke (find-objc-class 'ns-object)
'self 'id)
(primitive-invoke (find-objc-class 'ns-number)
--
cgit v1.2.3