diff options
Diffstat (limited to 'Lisp')
| -rw-r--r-- | Lisp/constant-data.lisp | 4 | ||||
| -rw-r--r-- | Lisp/memory-management.lisp | 9 | ||||
| -rw-r--r-- | Lisp/method-invocation.lisp | 30 |
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 |