From 8c5db651a2d55a8692b0dd78e37d4c01c4794585 Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Thu, 4 Oct 2007 22:03:25 +0200 Subject: Make PRIMITIVE-INVOKE compatible with Allegro CL. darcs-hash:fbad6db938521eb19fe3bf74ed61ad4577651276 --- Lisp/memory-management.lisp | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'Lisp/memory-management.lisp') 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))))) -- cgit v1.2.3