summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2007-10-04 22:03:25 +0200
committerMatthias Benkard <code@mail.matthias.benkard.de>2007-10-04 22:03:25 +0200
commit8c5db651a2d55a8692b0dd78e37d4c01c4794585 (patch)
tree6464d1133b0bb9f1011e2732c6f8938f930d1a87 /Lisp
parent37222b85b82a8152dbf5223cb346e3114f167624 (diff)
Make PRIMITIVE-INVOKE compatible with Allegro CL.
darcs-hash:fbad6db938521eb19fe3bf74ed61ad4577651276
Diffstat (limited to 'Lisp')
-rw-r--r--Lisp/constant-data.lisp4
-rw-r--r--Lisp/memory-management.lisp9
-rw-r--r--Lisp/method-invocation.lisp30
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