On Thu, 2005-12-22 at 17:19 +0100, Hoehle, Joerg-Cyril wrote:
> As an afterthought, it appears the low-level API would better not rely
> on SETF, and e.g. define %MEM-SET for writing. All these
> define-setf-expanders just to avoid piling up LET-rebindings to ensure
> correct order of evaluation yet still be able to optimize are not
> enjoyable.
> E.g. (setf MEM-REF) is still not optimized away in CLISP. I presume it
> does with cmucl, because cffi-cmucl has a suitable setf-expander. Some
> day I'll write the same for CLISP.
You're right---the interface sort of evolved from an early
implementation without compiler macros and I never realized that I
wasn't gaining anything by continuing to use SETF (since this is an
internal interface after all).
Here's a patch that does this---I've tested it on SBCL and CMUCL, would
anyone else like to give it a spin before merging?
James
--- old-cffi-luis/src/cffi-allegro.lisp 2005-12-17 15:56:00.000000000 -0800
+++ new-cffi-luis/src/cffi-allegro.lisp 2005-12-22 17:35:13.000000000 -0800
@@ -47,6 +47,7 @@
#:%load-foreign-library
#:%close-foreign-library
#:%mem-ref
+ #:%mem-set
;#:make-shareable-byte-vector
;#:with-pointer-to-vector-data
#:foreign-symbol-pointer
@@ -162,7 +163,7 @@
(setf ptr (inc-pointer ptr offset)))
(ff:fslot-value-typed (convert-foreign-type type) :c ptr))
-(defun (setf %mem-ref) (value ptr type &optional (offset 0))
+(defun %mem-set (value ptr type &optional (offset 0))
"Set the object of TYPE at OFFSET bytes from PTR."
(unless (zerop offset)
(setf ptr (inc-pointer ptr offset)))
@@ -329,4 +330,4 @@
"Returns a pointer to a foreign symbol NAME. KIND is one of
:CODE or :DATA, and is ignored on some platforms."
(declare (ignore kind))
- (prog1 (ff:get-entry-point (convert-external-name name))))
\ No newline at end of file
+ (prog1 (ff:get-entry-point (convert-external-name name))))
--- old-cffi-luis/src/cffi-clisp.lisp 2005-12-22 17:26:56.000000000 -0800
+++ new-cffi-luis/src/cffi-clisp.lisp 2005-12-22 17:35:03.000000000 -0800
@@ -55,6 +55,7 @@
#:%load-foreign-library
#:%close-foreign-library
#:%mem-ref
+ #:%mem-set
#:foreign-symbol-pointer
#:%defcallback))
@@ -180,7 +181,7 @@
or Lisp number."
(ffi:memory-as ptr (convert-foreign-type type) offset))
-(defun (setf %mem-ref) (value ptr type &optional (offset 0))
+(defun %mem-set (value ptr type &optional (offset 0))
"Set a pointer OFFSET bytes from PTR to an object of built-in
foreign TYPE to VALUE."
(setf (ffi:memory-as ptr (convert-foreign-type type) offset) value))
--- old-cffi-luis/src/cffi-cmucl.lisp 2005-12-17 15:56:00.000000000 -0800
+++ new-cffi-luis/src/cffi-cmucl.lisp 2005-12-22 17:35:45.000000000 -0800
@@ -52,6 +52,7 @@
#:%load-foreign-library
#:%close-foreign-library
#:%mem-ref
+ #:%mem-set
#:make-shareable-byte-vector
#:with-pointer-to-vector-data
#:foreign-symbol-pointer
@@ -217,31 +218,6 @@
(:double (setf (sys:sap-ref-double ptr offset) value))
(:pointer (setf (sys:sap-ref-sap ptr offset) value))))
-(define-setf-expander %mem-ref (ptr type &optional (offset 0) &environment env)
- "SETF expander for %MEM-REF that doesn't rebind TYPE.
-This is necessary for the compiler macro on %MEM-SET to be able
-to open-code (SETF %MEM-REF) forms."
- (multiple-value-bind (dummies vals newval setter getter)
- (get-setf-expansion ptr env)
- (declare (ignore setter newval))
- (with-unique-names (store type-tmp offset-tmp)
- (values
- (append (unless (constantp type) (list type-tmp))
- (unless (constantp offset) (list offset-tmp))
- dummies)
- (append (unless (constantp type) (list type))
- (unless (constantp offset) (list offset))
- vals)
- (list store)
- `(progn
- (%mem-set ,store ,getter
- ,@(if (constantp type) (list type) (list type-tmp))
- ,@(if (constantp offset) (list offset) (list offset-tmp)))
- ,store)
- `(%mem-ref ,getter
- ,@(if (constantp type) (list type) (list type-tmp))
- ,@(if (constantp offset) (list offset) (list offset-tmp)))))))
-
(define-compiler-macro %mem-set (&whole form value ptr type &optional (offset 0))
"Compiler macro to open-code when TYPE is constant."
(if (constantp type)
@@ -356,4 +332,4 @@
(defun foreign-symbol-pointer (name kind)
"Returns a pointer to a foreign symbol NAME. KIND is one of
:CODE or :DATA, and is ignored on some platforms."
- (prog1 (ignore-errors (sys:foreign-symbol-address name :flavor kind))))
\ No newline at end of file
+ (prog1 (ignore-errors (sys:foreign-symbol-address name :flavor kind))))
--- old-cffi-luis/src/cffi-corman.lisp 2005-12-17 15:56:00.000000000 -0800
+++ new-cffi-luis/src/cffi-corman.lisp 2005-12-22 17:36:13.000000000 -0800
@@ -45,6 +45,7 @@
#:%foreign-type-size
#:%load-foreign-library
#:%mem-ref
+ #:%mem-set
;#:make-shareable-byte-vector
;#:with-pointer-to-vector-data
#:foreign-symbol-pointer
@@ -178,7 +179,7 @@
; `(cref (,(convert-foreign-type type) *) ,ptr ,offset)
; form))
-(defun (setf %mem-ref) (value ptr type &optional (offset 0))
+(defun %mem-set (value ptr type &optional (offset 0))
"Set the object of TYPE at OFFSET bytes from PTR."
(unless (eql offset 0)
(setq ptr (inc-pointer ptr offset)))
@@ -298,4 +299,4 @@
str)))
(when (not (cpointer-null ptr))
(return ptr))))
- (free str))))
\ No newline at end of file
+ (free str))))
--- old-cffi-luis/src/cffi-ecl.lisp 2005-12-17 15:56:00.000000000 -0800
+++ new-cffi-luis/src/cffi-ecl.lisp 2005-12-22 17:36:36.000000000 -0800
@@ -41,6 +41,7 @@
#:make-pointer
#:pointer-address
#:%mem-ref
+ #:%mem-set
#:%foreign-funcall
#:%foreign-type-alignment
#:%foreign-type-size
@@ -120,7 +121,7 @@
(si:foreign-data-ref-elt
(si:foreign-data-recast ptr (+ offset type-size) :void) offset type)))
-(defun (setf %mem-ref) (value ptr type &optional (offset 0))
+(defun %mem-set (value ptr type &optional (offset 0))
"Set an object of TYPE at OFFSET bytes from PTR."
(let* ((type (convert-foreign-type type))
(type-size (ffi:size-of-foreign-type type)))
--- old-cffi-luis/src/cffi-gcl.lisp 2005-11-08 22:08:04.000000000 -0800
+++ new-cffi-luis/src/cffi-gcl.lisp 2005-12-22 17:37:39.000000000 -0800
@@ -52,6 +52,7 @@
#:null-ptr-p
#:inc-ptr
#:%mem-ref
+ #:%mem-set
#:%foreign-funcall
#:%foreign-type-alignment
#:%foreign-type-size
@@ -181,7 +182,7 @@
(:double (ref-double ptr))
(:pointer (ref-ptr ptr))))
-(defun (setf %mem-ref) (value ptr type &optional (offset 0))
+(defun %mem-set (value ptr type &optional (offset 0))
(unless (zerop offset)
(incf ptr offset))
(ecase type
@@ -302,4 +303,4 @@
;;; XXX unimplemented
(defmacro foreign-var-ptr (name)
"Return a pointer pointing to the foreign symbol NAME."
- 0)
\ No newline at end of file
+ 0)
--- old-cffi-luis/src/cffi-lispworks.lisp 2005-12-22 17:26:56.000000000 -0800
+++ new-cffi-luis/src/cffi-lispworks.lisp 2005-12-22 17:38:06.000000000 -0800
@@ -46,6 +46,7 @@
#:%load-foreign-library
#:%close-foreign-library
#:%mem-ref
+ #:%mem-set
#:make-shareable-byte-vector
#:with-pointer-to-vector-data
#:foreign-symbol-pointer
@@ -151,7 +152,7 @@
(setf ptr (inc-pointer ptr offset)))
(fli:dereference ptr :type (convert-foreign-type type)))
-(defun (setf %mem-ref) (value ptr type &optional (offset 0))
+(defun %mem-set (value ptr type &optional (offset 0))
"Set the object of TYPE at OFFSET bytes from PTR."
(unless (zerop offset)
(setf ptr (inc-pointer ptr offset)))
--- old-cffi-luis/src/cffi-openmcl.lisp 2005-12-17 15:56:00.000000000 -0800
+++ new-cffi-luis/src/cffi-openmcl.lisp 2005-12-22 17:38:37.000000000 -0800
@@ -41,6 +41,7 @@
#:make-pointer
#:pointer-address
#:%mem-ref
+ #:%mem-set
#:%foreign-funcall
#:%foreign-funcall-pointer
#:%foreign-type-alignment
@@ -176,31 +177,6 @@
(:pointer `(%get-ptr ,ptr ,offset))))
form))
-(define-setf-expander %mem-ref (ptr type &optional (offset 0) &environment env)
- "SETF expander for %MEM-REF that doesn't rebind TYPE.
-This is necessary for the compiler macro on %MEM-SET to be able
-to open-code (SETF %MEM-REF) forms."
- (multiple-value-bind (dummies vals newval setter getter)
- (get-setf-expansion ptr env)
- (declare (ignore setter newval))
- (with-unique-names (store type-tmp offset-tmp)
- (values
- (append (unless (constantp type) (list type-tmp))
- (unless (constantp offset) (list offset-tmp))
- dummies)
- (append (unless (constantp type) (list type))
- (unless (constantp offset) (list offset))
- vals)
- (list store)
- `(progn
- (%mem-set ,store ,getter
- ,@(if (constantp type) (list type) (list type-tmp))
- ,@(if (constantp offset) (list offset) (list offset-tmp)))
- ,store)
- `(%mem-ref ,getter
- ,@(if (constantp type) (list type) (list type-tmp))
- ,@(if (constantp offset) (list offset) (list offset-tmp)))))))
-
(defun %mem-set (value ptr type &optional (offset 0))
"Set an object of TYPE at OFFSET bytes from PTR."
(ecase type
@@ -334,4 +310,4 @@
"Returns a pointer to a foreign symbol NAME. KIND is one of
:CODE or :DATA, and is ignored on some platforms."
(declare (ignore kind))
- (foreign-symbol-address (convert-external-name name)))
\ No newline at end of file
+ (foreign-symbol-address (convert-external-name name)))
--- old-cffi-luis/src/cffi-sbcl.lisp 2005-12-17 15:56:40.000000000 -0800
+++ new-cffi-luis/src/cffi-sbcl.lisp 2005-12-22 17:38:51.000000000 -0800
@@ -53,6 +53,7 @@
#:%load-foreign-library
#:%close-foreign-library
#:%mem-ref
+ #:%mem-set
#:make-shareable-byte-vector
#:with-pointer-to-vector-data
#:foreign-symbol-pointer
@@ -208,31 +209,6 @@
(:double (setf (sb-sys:sap-ref-double ptr offset) value))
(:pointer (setf (sb-sys:sap-ref-sap ptr offset) value))))
-(define-setf-expander %mem-ref (ptr type &optional (offset 0) &environment env)
- "SETF expander for %MEM-REF that doesn't rebind TYPE.
-This is necessary for the compiler macro on %MEM-SET to be able
-to open-code (SETF %MEM-REF) forms."
- (multiple-value-bind (dummies vals newval setter getter)
- (get-setf-expansion ptr env)
- (declare (ignore setter newval))
- (with-unique-names (store type-tmp offset-tmp)
- (values
- (append (unless (constantp type) (list type-tmp))
- (unless (constantp offset) (list offset-tmp))
- dummies)
- (append (unless (constantp type) (list type))
- (unless (constantp offset) (list offset))
- vals)
- (list store)
- `(progn
- (%mem-set ,store ,getter
- ,@(if (constantp type) (list type) (list type-tmp))
- ,@(if (constantp offset) (list offset) (list offset-tmp)))
- ,store)
- `(%mem-ref ,getter
- ,@(if (constantp type) (list type) (list type-tmp))
- ,@(if (constantp offset) (list offset) (list offset-tmp)))))))
-
(define-compiler-macro %mem-set (&whole form value ptr type &optional (offset 0))
"Compiler macro to open-code when TYPE is constant."
(if (constantp type)
@@ -362,4 +338,4 @@
"Returns a pointer to a foreign symbol NAME. KIND is one of
:CODE or :DATA, and is ignored on some platforms."
(when (sb-sys:find-foreign-symbol-address name)
- (sb-sys:foreign-symbol-sap name (ecase kind (:code nil) (:data t)))))
\ No newline at end of file
+ (sb-sys:foreign-symbol-sap name (ecase kind (:code nil) (:data t)))))
--- old-cffi-luis/src/strings.lisp 2005-12-11 20:56:28.000000000 -0800
+++ new-cffi-luis/src/strings.lisp 2005-12-22 17:39:54.000000000 -0800
@@ -39,8 +39,8 @@
(decf size)
(loop with i = 0 for char across string
while (< i size)
- do (setf (%mem-ref ptr :unsigned-char (post-incf i)) (char-code char))
- finally (setf (%mem-ref ptr :unsigned-char i) 0)))
+ do (%mem-set (char-code char) ptr :unsigned-char (post-incf i))
+ finally (%mem-set 0 ptr :unsigned-char i)))
(defun foreign-string-to-lisp (ptr &optional (size most-positive-fixnum)
(null-terminated-p t))
@@ -133,4 +133,4 @@
(define-type-translator :string+ptr :from-c (value)
"Return both the string and the pointer in list."
(once-only (value)
- `(list (foreign-string-to-lisp ,value) ,value)))
\ No newline at end of file
+ `(list (foreign-string-to-lisp ,value) ,value)))
--- old-cffi-luis/src/types.lisp 2005-12-22 17:26:56.000000000 -0800
+++ new-cffi-luis/src/types.lisp 2005-12-22 17:34:01.000000000 -0800
@@ -177,7 +177,7 @@
(defun mem-set (value ptr type &optional (offset 0))
"Set the value of TYPE at OFFSET from PTR to VALUE."
- (setf (%mem-ref ptr (canonicalize-foreign-type type) offset) value))
+ (%mem-set value ptr (canonicalize-foreign-type type) offset))
(define-setf-expander mem-ref (ptr type &optional (offset 0) &environment env)
"SETF expander for MEM-REF that doesn't rebind TYPE.
@@ -210,8 +210,7 @@
(&whole form value ptr type &optional (offset 0))
"Compiler macro to open-code (SETF MEM-REF) when type is constant."
(if (constantp type)
- `(setf (%mem-ref ,ptr ,(canonicalize-foreign-type (eval type))
- ,offset) ,value)
+ `(%mem-set ,value ,ptr ,(canonicalize-foreign-type (eval type)) ,offset)
form))
;;;# Dereferencing Foreign Arrays
@@ -753,4 +752,4 @@
`(not (zerop ,value)))
(define-type-translator :boolean :to-c (value)
- `(if ,value 1 0))
\ No newline at end of file
+ `(if ,value 1 0))
_______________________________________________
cffi-devel mailing list
cffi-devel@common-lisp.net
http://common-lisp.net/cgi-bin/mailman/listinfo/cffi-devel
