To confirm, I have tested the 8-Jan-2008, plus the two patches Allegro:
allegro-wfp
allegro-pointer
and it seems to work fine on 64-bit and 32-bit. We haven't given it
extensive testing.
The crash bug with defcfun strerror on 64-bit is gone.
Just for reference here is the combined patch against the 8 Jan version
that I am using.
Thanks for the speedy and helpful response!
diff --recursive -u -p cffi-090108/src/cffi-allegro.lisp cffi/src/cffi-allegro.lisp
--- cffi-090108/src/cffi-allegro.lisp 2009-01-09 09:42:03.000000000 +0900
+++ cffi/src/cffi-allegro.lisp 2009-01-13 15:27:17.000000000 +0900
@@ -130,27 +130,21 @@ may be stack-allocated if supported by t
SIZE-VAR is supplied, it will be bound to SIZE during BODY."
(unless size-var
(setf size-var (gensym "SIZE")))
- #+(version>= 8 1)
- (cond ((and (constantp size) (<= (eval size) ff:*max-stack-fobject-bytes*))
- ;; stack allocation
- `(let ((,size-var ,size))
- (declare (ignorable ,size-var))
- (ff:with-stack-fobject (,var '(:array :char ,size)
- :allocation :foreign-static-gc)
- ;; (excl::stack-allocated-p var) => T
- (let ((,var (ff:fslot-address ,var)))
- ,@body))))
- (t
- ;; heap allocation
- `(let ((,size-var ,size))
- (ff:with-stack-fobject (,var :char :allocation :c :size ,size-var)
- (unwind-protect
- (progn ,@body)
- (ff:free-fobject ,var))))))
- #-(version>= 8 1)
- `(let ((,size-var ,size))
- (ff:with-stack-fobject (,var :char :c ,size-var)
- ,@body)))
+ #+(version>= 8 1)
+ (when (and (constantp size) (<= (eval size) ff:*max-stack-fobject-bytes*))
+ (return-from with-foreign-pointer
+ `(let ((,size-var ,size))
+ (declare (ignorable ,size-var))
+ (ff:with-static-fobject (,var '(:array :char ,size)
+ :allocation :foreign-static-gc)
+ ;; (excl::stack-allocated-p var) => T
+ (let ((,var (ff:fslot-address ,var)))
+ ,@body)))))
+ `(let* ((,size-var ,size)
+ (,var (ff:allocate-fobject :char :c ,size-var)))
+ (unwind-protect
+ (progn ,@body)
+ (ff:free-fobject ,var))))
;;;# Shareable Vectors
;;;
@@ -171,7 +165,7 @@ SIZE-VAR is supplied, it will be bound t
;;;# Dereferencing
-(defun convert-foreign-type (type-keyword &optional (context :normal))
+(defun convert-foreign-type (type-keyword)
"Convert a CFFI type keyword to an Allegro type."
(ecase type-keyword
(:char :char)
@@ -184,9 +178,7 @@ SIZE-VAR is supplied, it will be bound t
(:unsigned-long :unsigned-long)
(:float :float)
(:double :double)
- (:pointer (ecase context
- (:normal '(* :void))
- (:funcall :foreign-address)))
+ (:pointer :unsigned-nat)
(:void :void)))
(defun %mem-ref (ptr type &optional (offset 0))
@@ -243,36 +235,24 @@ SIZE-VAR is supplied, it will be bound t
"Returns a list of types, list of args and return type."
(let ((return-type :void))
(loop for (type arg) on args by #'cddr
- if arg collect (convert-foreign-type type :funcall) into types
+ if arg collect type into types
and collect arg into fargs
- else do (setf return-type (convert-foreign-type type :funcall))
+ else do (setf return-type type)
finally (return (values types fargs return-type)))))
(defun convert-to-lisp-type (type)
- (if (equal '(* :void) type)
- 'integer
- (ecase type
- (:char 'signed-byte)
- (:unsigned-char 'integer) ;'unsigned-byte)
- ((:short
- :unsigned-short
- :int
- :unsigned-int
- :long
- :unsigned-long) 'integer)
- (:float 'single-float)
- (:double 'double-float)
- (:foreign-address :foreign-address)
- (:void 'null))))
-
-(defun foreign-allegro-type (type)
- (if (eq type :foreign-address)
- nil
- type))
-
-(defun allegro-type-pair (type)
- (list (foreign-allegro-type type)
- (convert-to-lisp-type type)))
+ (ecase type
+ ((:char :short :int :long)
+ `(signed-byte ,(* 8 (ff:sizeof-fobject type))))
+ ((:unsigned-char :unsigned-short :unsigned-int :unsigned-long :unsigned-nat)
+ `(unsigned-byte ,(* 8 (ff:sizeof-fobject type))))
+ (:float 'single-float)
+ (:double 'double-float)
+ (:void 'null)))
+
+(defun allegro-type-pair (cffi-type)
+ (let ((ftype (convert-foreign-type cffi-type)))
+ (list ftype (convert-to-lisp-type ftype))))
#+ignore
(defun note-named-foreign-function (symbol name types rettype)
@@ -283,11 +263,9 @@ SIZE-VAR is supplied, it will be bound t
t ; callback
:c ; convention
;; return type '(:c-type lisp-type)
- ',(allegro-type-pair (convert-foreign-type rettype :funcall))
+ ',(allegro-type-pair rettype)
;; arg types '({(:c-type lisp-type)}*)
- '(,@(loop for type in types
- collect (allegro-type-pair
- (convert-foreign-type type :funcall))))
+ '(,@(mapcar #'allegro-type-pair types))
nil ; arg-checking
ff::ep-flag-never-release))))
@@ -313,19 +291,15 @@ SIZE-VAR is supplied, it will be bound t
(declare (ignore options))
(let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name))))
(values
- `(ff:def-foreign-call (,ff-name ,name)
- ,(mapcar (lambda (ty)
- (let ((allegro-type (convert-foreign-type ty)))
- (list (gensym) allegro-type
- (convert-to-lisp-type allegro-type))))
- types)
- :returning ,(allegro-type-pair
- (convert-foreign-type rettype :funcall))
- ;; Don't use call-direct when there are no arguments.
- ,@(unless (null args) '(:call-direct t))
- :arg-checking nil
- :strings-convert nil)
- `(,ff-name ,@args))))
+ `(ff:def-foreign-call (,ff-name ,name)
+ ,(loop for type in types
+ collect (list* (gensym) (allegro-type-pair type)))
+ :returning ,(allegro-type-pair rettype)
+ ;; Don't use call-direct when there are no arguments.
+ ,@(unless (null args) '(:call-direct t))
+ :arg-checking nil
+ :strings-convert nil)
+ `(,ff-name ,@args))))
;;; See doc/allegro-internals.txt for a clue about entry-vec.
(defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
_______________________________________________
cffi-devel mailing list
cffi-devel@common-lisp.net
http://common-lisp.net/cgi-bin/mailman/listinfo/cffi-devel
