Make PRIMITIVE-INVOKE compatible with Allegro CL.

darcs-hash:fbad6db938521eb19fe3bf74ed61ad4577651276

3 files changed, 27 insertions, 16 deletions

diff --git a/Lisp/constant-data.lisp b/Lisp/constant-data.lisp
index e44147c..f637ed5 100644
--- a/Lisp/constant-data.lisp
+++ b/Lisp/constant-data.lisp
@@ -89,8 +89,8 @@
     (flt      . single-float)
     (dbl      . double-float)
     (bool     . boolean)
-    (ptr      . c-pointer)
-    (charptr  . string)))
+    (charptr  . string)
+    (ptr      . c-pointer)))
 
 
 (defparameter *objcl-c-type-map*
diff --git a/Lisp/memory-management.lisp b/Lisp/memory-management.lisp
index 94e647f..c977a49 100644
--- a/Lisp/memory-management.lisp
+++ b/Lisp/memory-management.lisp
@@ -33,7 +33,10 @@
                        ((selector) *selector-objects*)
                        ((objc-meta-class) *meta-class-objects*)))
          (address (cffi:pointer-address pointer))
-         (object (weak-gethash address hash-table nil)))
+         (object (weak-gethash address hash-table nil))
+         (constructor (case class
+                        ((exception) #'make-condition)
+                        (otherwise #'make-instance))))
     (if object
         object
         (progn
@@ -59,7 +62,7 @@
           ;; By the way, is using the return value of SETF considered
           ;; bad style?
           (let* ((*in-make-pointer-wrapper-p* t)
-                 (new-wrapper (apply #'make-instance class initargs)))
+                 (new-wrapper (apply constructor class initargs)))
             (setf (weak-gethash address hash-table) new-wrapper)
             ;; As classes always have a retain count of -1, we don't
             ;; have to do memory management for them.  Meanwhile,
@@ -91,7 +94,7 @@
                        ;; happily take a pointer as its first argument,
                        ;; but why push our luck?)
                        (let* ((temporary-wrapper
-                               (make-instance class :pointer pointer)))
+                               (funcall constructor class :pointer pointer)))
                          (primitive-invoke temporary-wrapper "release" :void))))
                 (trivial-garbage:finalize new-wrapper #'finalizer)))
             new-wrapper)))))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 8f80621..b260f2a 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -231,15 +231,25 @@ easier to use with __apply__.
                            for i from 0 to raw-argc
                            do (let* ((type-name (lisp-value->type-name arg)))
                                 (typecase arg
+                                  ;; According to Allegro CL, strings
+                                  ;; are POINTERP (and thus elements of
+                                  ;; the C-POINTER type), so they have
+                                  ;; to come first in this TYPECASE
+                                  ;; form.  Weird.
+                                  ;;
+                                  ;; By the way, pointers are
+                                  ;; represented as integers in Allegro
+                                  ;; CL, so all integers are POINTERP,
+                                  ;; too.
+                                  (string
+                                   (setf (argref :string (+ i 2))
+                                         (alloc-string-and-register 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)))
@@ -247,14 +257,12 @@ easier to use with __apply__.
                                       (alloc-string-and-register
                                        (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 raw-argc
-                                                return-type-cell
-                                                arg-types
-                                                return-value-cell
-                                                objc-arg-ptrs)))
+              (let ((error-cell
+                     (%objcl-invoke-with-types raw-argc
+                                               (type-name->type-id return-type)
+                                               arg-types
+                                               return-value-cell
+                                               objc-arg-ptrs)))
                 (unless (cffi:null-pointer-p error-cell)
                   ;; Note that we do not FOREIGN-FREE the error cell,
                   ;; because it is either a null pointer or a pointer to