PRIMITIVE-INVOKE: Fix a bunch of memory access bugs.

darcs-hash:36acfdc03f4004a971aa31a81b87e40c52940f82

1 files changed, 76 insertions, 69 deletions

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")