From 495f0fb1d8ccb62d9a7e121119b2d894d47d40fb Mon Sep 17 00:00:00 2001 From: Samuel Hunter Date: Mon, 7 Nov 2022 15:48:21 -0800 Subject: [PATCH 1/2] Switch compiler macros to CONSTANT-FORM-VALUE instead of CL:EVAL --- src/early-types.lisp | 12 ++--- src/enum.lisp | 16 +++---- src/types.lisp | 112 +++++++++++++++++++++---------------------- 3 files changed, 70 insertions(+), 70 deletions(-) diff --git a/src/early-types.lisp b/src/early-types.lisp index aa13c013e9e6..251a91841294 100644 --- a/src/early-types.lisp +++ b/src/early-types.lisp @@ -629,24 +629,24 @@ Signals an error if the type cannot be resolved." (translate-to-foreign value (parse-type type))) (define-compiler-macro convert-to-foreign (value type) - (if (constantp type) - (expand-to-foreign value (parse-type (eval type))) + (if (constant-form-p type) + (expand-to-foreign value (parse-type (constant-form-value type))) `(translate-to-foreign ,value (parse-type ,type)))) (defun convert-from-foreign (value type) (translate-from-foreign value (parse-type type))) (define-compiler-macro convert-from-foreign (value type) - (if (constantp type) - (expand-from-foreign value (parse-type (eval type))) + (if (constant-form-p type) + (expand-from-foreign value (parse-type (constant-form-value type))) `(translate-from-foreign ,value (parse-type ,type)))) (defun convert-into-foreign-memory (value type ptr) (translate-into-foreign-memory value (parse-type type) ptr)) (define-compiler-macro convert-into-foreign-memory (value type ptr) - (if (constantp type) - (expand-into-foreign-memory value (parse-type (eval type)) ptr) + (if (constant-form-p type) + (expand-into-foreign-memory value (parse-type (constant-form-value type)) ptr) `(translate-into-foreign-memory ,value (parse-type ,type) ,ptr))) (defun free-converted-object (value type param) diff --git a/src/enum.lisp b/src/enum.lisp index 437446d5d2f1..35e1a99c0b23 100644 --- a/src/enum.lisp +++ b/src/enum.lisp @@ -321,8 +321,8 @@ (define-compiler-macro foreign-bitfield-value (&whole form type symbols) "Optimize for when TYPE and SYMBOLS are constant." (declare (notinline foreign-bitfield-value)) - (if (and (constantp type) (constantp symbols)) - (foreign-bitfield-value (eval type) (eval symbols)) + (if (and (constant-form-p type) (constant-form-p symbols)) + (foreign-bitfield-value (constant-form-value type) (constant-form-value symbols)) form)) (defun %foreign-bitfield-symbols (type value) @@ -348,8 +348,8 @@ the bitfield TYPE." (define-compiler-macro foreign-bitfield-symbols (&whole form type value) "Optimize for when TYPE and SYMBOLS are constant." (declare (notinline foreign-bitfield-symbols)) - (if (and (constantp type) (constantp value)) - `(quote ,(foreign-bitfield-symbols (eval type) (eval value))) + (if (and (constant-form-p type) (constant-form-p value)) + `(quote ,(foreign-bitfield-symbols (constant-form-value type) (constant-form-value value))) form)) (defmethod translate-to-foreign (value (type foreign-bitfield)) @@ -365,13 +365,13 @@ the bitfield TYPE." `(if (integerp ,value) ,value (%foreign-bitfield-value ,type (ensure-list ,value))))) - (if (constantp value) - (eval (expander value type)) + (if (constant-form-p value) + (constant-form-value (expander value type)) (expander value type)))) (defmethod expand-from-foreign (value (type foreign-bitfield)) (flet ((expander (value type) `(%foreign-bitfield-symbols ,type ,value))) - (if (constantp value) - (eval (expander value type)) + (if (constant-form-p value) + (constant-form-value (expander value type)) (expander value type)))) diff --git a/src/types.lisp b/src/types.lisp index aa01a3ea63f8..21d6c209bde4 100644 --- a/src/types.lisp +++ b/src/types.lisp @@ -124,8 +124,8 @@ ;;;# Foreign Pointers (define-compiler-macro inc-pointer (&whole form pointer offset) - (if (and (constantp offset) - (eql 0 (eval offset))) + (if (and (constant-form-p offset) + (eql 0 (constant-form-value offset))) pointer form)) @@ -150,8 +150,8 @@ we don't return its 'value' but a pointer to it, which is PTR itself." (define-compiler-macro mem-ref (&whole form ptr type &optional (offset 0)) "Compiler macro to open-code MEM-REF when TYPE is constant." - (if (constantp type) - (let* ((parsed-type (parse-type (eval type))) + (if (constant-form-p type) + (let* ((parsed-type (parse-type (constant-form-value type))) (ctype (canonicalize parsed-type))) ;; Bail out when using emulated long long types. #+cffi-sys::no-long-long @@ -188,27 +188,27 @@ to open-code (SETF MEM-REF) forms." ;; so that the compiler macros on MEM-SET and %MEM-SET work. (with-unique-names (store type-tmp offset-tmp) (values - (append (unless (constantp type) (list type-tmp)) - (unless (constantp offset) (list offset-tmp)) + (append (unless (constant-form-p type) (list type-tmp)) + (unless (constant-form-p offset) (list offset-tmp)) dummies) - (append (unless (constantp type) (list type)) - (unless (constantp offset) (list offset)) + (append (unless (constant-form-p type) (list type)) + (unless (constant-form-p 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))) + ,@(if (constant-form-p type) (list type) (list type-tmp)) + ,@(if (constant-form-p 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))))))) + ,@(if (constant-form-p type) (list type) (list type-tmp)) + ,@(if (constant-form-p offset) (list offset) (list offset-tmp))))))) (define-compiler-macro mem-set (&whole form value ptr type &optional (offset 0)) "Compiler macro to open-code (SETF MEM-REF) when type is constant." - (if (constantp type) - (let* ((parsed-type (parse-type (eval type))) + (if (constant-form-p type) + (let* ((parsed-type (parse-type (constant-form-value type))) (ctype (canonicalize parsed-type))) ;; Bail out when using emulated long long types. #+cffi-sys::no-long-long @@ -230,11 +230,11 @@ to open-code (SETF MEM-REF) forms." (define-compiler-macro mem-aref (&whole form ptr type &optional (index 0)) "Compiler macro to open-code MEM-AREF when TYPE (and eventually INDEX)." - (if (constantp type) - (if (constantp index) + (if (constant-form-p type) + (if (constant-form-p index) `(mem-ref ,ptr ,type - ,(* (eval index) (foreign-type-size (eval type)))) - `(mem-ref ,ptr ,type (* ,index ,(foreign-type-size (eval type))))) + ,(* (constant-form-value index) (foreign-type-size (constant-form-value type)))) + `(mem-ref ,ptr ,type (* ,index ,(foreign-type-size (constant-form-value type))))) form)) (define-setf-expander mem-aref (ptr type &optional (index 0) &environment env) @@ -247,34 +247,34 @@ to open-code (SETF MEM-REF) forms." ;; on MEM-SET or %MEM-SET can work. (with-unique-names (store type-tmp index-tmp) (values - (append (unless (constantp type) + (append (unless (constant-form-p type) (list type-tmp)) - (unless (and (constantp type) (constantp index)) + (unless (and (constant-form-p type) (constant-form-p index)) (list index-tmp)) dummies) - (append (unless (constantp type) + (append (unless (constant-form-p type) (list type)) - (unless (and (constantp type) (constantp index)) + (unless (and (constant-form-p type) (constant-form-p index)) (list index)) vals) (list store) ;; Here we'll try to calculate the offset from the type and index, ;; or if not possible at least get the type size early. `(progn - ,(if (constantp type) - (if (constantp index) + ,(if (constant-form-p type) + (if (constant-form-p index) `(mem-set ,store ,getter ,type - ,(* (eval index) (foreign-type-size (eval type)))) + ,(* (constant-form-value index) (foreign-type-size (constant-form-value type)))) `(mem-set ,store ,getter ,type - (* ,index-tmp ,(foreign-type-size (eval type))))) + (* ,index-tmp ,(foreign-type-size (constant-form-value type))))) `(mem-set ,store ,getter ,type-tmp (* ,index-tmp (foreign-type-size ,type-tmp)))) ,store) `(mem-aref ,getter - ,@(if (constantp type) + ,@(if (constant-form-p type) (list type) (list type-tmp)) - ,@(if (and (constantp type) (constantp index)) + ,@(if (and (constant-form-p type) (constant-form-p index)) (list index) (list index-tmp))))))) @@ -292,15 +292,15 @@ to open-code (SETF MEM-REF) forms." (define-compiler-macro mem-aptr (&whole form ptr type &optional (index 0)) "The pointer to the element." - (cond ((not (constantp type)) + (cond ((not (constant-form-p type)) form) - ((not (constantp index)) - `(inc-pointer ,ptr (* ,index ,(foreign-type-size (eval type))))) - ((zerop (eval index)) + ((not (constant-form-p index)) + `(inc-pointer ,ptr (* ,index ,(foreign-type-size (constant-form-value type))))) + ((zerop (constant-form-value index)) ptr) (t - `(inc-pointer ,ptr ,(* (eval index) - (foreign-type-size (eval type))))))) + `(inc-pointer ,ptr ,(* (constant-form-value index) + (foreign-type-size (constant-form-value type))))))) (define-foreign-type foreign-array-type () ((dimensions :reader dimensions :initarg :dimensions) @@ -386,10 +386,10 @@ newly allocated memory." &key (count 1 count-p) &allow-other-keys) (if (or (and count-p (<= (length args) 2)) (null args)) (cond - ((and (constantp type) (constantp count)) - `(%foreign-alloc ,(* (eval count) (foreign-type-size (eval type))))) - ((constantp type) - `(%foreign-alloc (* ,count ,(foreign-type-size (eval type))))) + ((and (constant-form-p type) (constant-form-p count)) + `(%foreign-alloc ,(* (constant-form-value count) (foreign-type-size (constant-form-value type))))) + ((constant-form-p type) + `(%foreign-alloc (* ,count ,(foreign-type-size (constant-form-value type))))) (t form)) form)) @@ -774,9 +774,9 @@ The foreign array must be freed with foreign-array-free." (foreign-struct-slot-pointer ptr (get-slot-info type slot-name))) (define-compiler-macro foreign-slot-pointer (&whole whole ptr type slot-name) - (if (and (constantp type) (constantp slot-name)) + (if (and (constant-form-p type) (constant-form-p slot-name)) (foreign-struct-slot-pointer-form - ptr (get-slot-info (eval type) (eval slot-name))) + ptr (get-slot-info (constant-form-value type) (constant-form-value slot-name))) whole)) (defun foreign-slot-type (type slot-name) @@ -797,9 +797,9 @@ The foreign array must be freed with foreign-array-free." (define-compiler-macro foreign-slot-value (&whole form ptr type slot-name) "Optimizer for FOREIGN-SLOT-VALUE when TYPE is constant." - (if (and (constantp type) (constantp slot-name)) + (if (and (constant-form-p type) (constant-form-p slot-name)) (foreign-struct-slot-value-form - ptr (get-slot-info (eval type) (eval slot-name))) + ptr (get-slot-info (constant-form-value type) (constant-form-value slot-name))) form)) (define-setf-expander foreign-slot-value (ptr type slot-name &environment env) @@ -807,7 +807,7 @@ The foreign array must be freed with foreign-array-free." (multiple-value-bind (dummies vals newval setter getter) (get-setf-expansion ptr env) (declare (ignore setter newval)) - (if (and (constantp type) (constantp slot-name)) + (if (and (constant-form-p type) (constant-form-p slot-name)) ;; if TYPE and SLOT-NAME are constant we avoid rebinding them ;; so that the compiler macro on FOREIGN-SLOT-SET works. (with-unique-names (store) @@ -837,16 +837,16 @@ The foreign array must be freed with foreign-array-free." (define-compiler-macro foreign-slot-set (&whole form value ptr type slot-name) "Optimizer when TYPE and SLOT-NAME are constant." - (if (and (constantp type) (constantp slot-name)) + (if (and (constant-form-p type) (constant-form-p slot-name)) (foreign-struct-slot-set-form - value ptr (get-slot-info (eval type) (eval slot-name))) + value ptr (get-slot-info (constant-form-value type) (constant-form-value slot-name))) form)) (defmacro with-foreign-slots ((vars ptr type) &body body) "Create local symbol macros for each var in VARS to reference foreign slots in PTR of TYPE. Similar to WITH-SLOTS. -Each var can be of the form: - name name bound to slot of same name +Each var can be of the form: + name name bound to slot of same name (:pointer name) name bound to pointer to slot of same name (name slot-name) name bound to slot-name (name :pointer slot-name) name bound to pointer to slot-name" @@ -857,7 +857,7 @@ Each var can be of the form: :collect (if (listp var) (let ((p1 (first var)) (p2 (second var)) (p3 (third var))) - (if (eq p1 :pointer) + (if (eq p1 :pointer) `(,p2 (foreign-slot-pointer ,ptr-var ',type ',p2)) (if (eq p2 :pointer) `(,p1 (foreign-slot-pointer ,ptr-var ',type ',p3)) @@ -951,11 +951,11 @@ slots will be defined and stored." "Bind VAR to a pointer to COUNT objects of TYPE during BODY. The buffer has dynamic extent and may be stack allocated." `(with-foreign-pointer - (,var ,(if (constantp type) + (,var ,(if (constant-form-p type) ;; with-foreign-pointer may benefit from constant folding: - (if (constantp count) - (* (eval count) (foreign-type-size (eval type))) - `(* ,count ,(foreign-type-size (eval type)))) + (if (constant-form-p count) + (* (constant-form-value count) (foreign-type-size (constant-form-value type))) + `(* ,count ,(foreign-type-size (constant-form-value type)))) `(* ,count (foreign-type-size ,type)))) ,@body)) @@ -1014,14 +1014,14 @@ The buffer has dynamic extent and may be stack allocated." (defmethod expand-to-foreign (value (type foreign-boolean-type)) "Optimization for the :boolean type." - (if (constantp value) - (if (eval value) 1 0) + (if (constant-form-p value) + (if (constant-form-value value) 1 0) `(if ,value 1 0))) (defmethod expand-from-foreign (value (type foreign-boolean-type)) "Optimization for the :boolean type." - (if (constantp value) ; very unlikely, heh - (not (zerop (eval value))) + (if (constant-form-p value) ; very unlikely, heh + (not (zerop (constant-form-value value))) `(not (zerop ,value)))) ;;; Boolean type that represents C99 _Bool From 5e24d76cc1a4fb2c078ea7914236bc91ff14a8d9 Mon Sep 17 00:00:00 2001 From: Samuel Hunter Date: Mon, 14 Nov 2022 23:21:46 -0800 Subject: [PATCH 2/2] Switch cffi-sys compiler macros from CL:EVAL CONSTANT-FORM-VALUE --- src/cffi-allegro.lisp | 17 ++++++++++------- src/cffi-clisp.lisp | 8 ++++---- src/cffi-cmucl.lisp | 15 ++++++++------- src/cffi-corman.lisp | 2 +- src/cffi-ecl.lisp | 8 ++++---- src/cffi-lispworks.lisp | 16 ++++++++-------- src/cffi-mcl.lisp | 10 +++++----- src/cffi-openmcl.lisp | 8 ++++---- src/cffi-sbcl.lisp | 15 ++++++++------- src/cffi-scl.lisp | 13 +++++++------ 10 files changed, 59 insertions(+), 53 deletions(-) diff --git a/src/cffi-allegro.lisp b/src/cffi-allegro.lisp index 7b0ff66ced46..c7b788aea553 100644 --- a/src/cffi-allegro.lisp +++ b/src/cffi-allegro.lisp @@ -98,9 +98,10 @@ SIZE-VAR is supplied, it will be bound to SIZE during BODY." (unless size-var (setf size-var (gensym "SIZE"))) #+(version>= 8 1) - (when (and (constantp size) (<= (eval size) ff:*max-stack-fobject-bytes*)) + (when (and (constant-form-p size) + (<= (constant-form-value size) ff:*max-stack-fobject-bytes*)) (return-from with-foreign-pointer - `(let ((,size-var ,(eval size))) + `(let ((,size-var ,(constant-form-value size))) (declare (ignorable ,size-var)) (ff:with-static-fobject (,var '(:array :char ,(eval size)) :allocation :foreign-static-gc) @@ -171,10 +172,11 @@ WITH-POINTER-TO-VECTOR-DATA." ;;; CFFI type is constant. Allegro does its own transformation on the ;;; call that results in efficient code. (define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0)) - (if (constantp type) + (if (constant-form-p type) (let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off)))) - `(ff:fslot-value-typed ',(convert-foreign-type (eval type)) - :c ,ptr-form)) + `(ff:fslot-value-typed + ',(convert-foreign-type (constant-form-value type)) + :c ,ptr-form)) form)) (defun %mem-set (value ptr type &optional (offset 0)) @@ -187,10 +189,11 @@ WITH-POINTER-TO-VECTOR-DATA." ;;; when the CFFI type is constant. Allegro does its own ;;; transformation on the call that results in efficient code. (define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0)) - (if (constantp type) + (if (constant-form-p type) (once-only (val) (let ((ptr-form (if (eql off 0) ptr `(+ ,ptr ,off)))) - `(setf (ff:fslot-value-typed ',(convert-foreign-type (eval type)) + `(setf (ff:fslot-value-typed ',(convert-foreign-type + (constant-form-value type)) :c ,ptr-form) ,val))) form)) diff --git a/src/cffi-clisp.lisp b/src/cffi-clisp.lisp index 92c3856040d7..8ce4d2c55f4a 100644 --- a/src/cffi-clisp.lisp +++ b/src/cffi-clisp.lisp @@ -154,8 +154,8 @@ or Lisp number." (define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0)) "Compiler macro to open-code when TYPE is constant." - (if (constantp type) - (let* ((ftype (convert-foreign-type (eval type))) + (if (constant-form-p type) + (let* ((ftype (convert-foreign-type (constant-form-value type))) (form `(ffi:memory-as ,ptr ',ftype ,offset))) (if (eq type :pointer) `(or ,form (null-pointer)) @@ -169,11 +169,11 @@ foreign TYPE to VALUE." (define-compiler-macro %mem-set (&whole form value ptr type &optional (offset 0)) - (if (constantp type) + (if (constant-form-p type) ;; (setf (ffi:memory-as) value) is exported, but not so nice ;; w.r.t. the left to right evaluation rule `(ffi::write-memory-as - ,value ,ptr ',(convert-foreign-type (eval type)) ,offset) + ,value ,ptr ',(convert-foreign-type (constant-form-value type)) ,offset) form)) ;;;# Shareable Vectors diff --git a/src/cffi-cmucl.lisp b/src/cffi-cmucl.lisp index a5fd8b50d217..33f77a1e038c 100644 --- a/src/cffi-cmucl.lisp +++ b/src/cffi-cmucl.lisp @@ -85,10 +85,11 @@ SIZE-VAR is supplied, it will be bound to SIZE during BODY." (unless size-var (setf size-var (gensym "SIZE"))) ;; If the size is constant we can stack-allocate. - (if (constantp size) + (if (constant-form-p size) (let ((alien-var (gensym "ALIEN"))) - `(with-alien ((,alien-var (array (unsigned 8) ,(eval size)))) - (let ((,size-var ,(eval size)) + `(with-alien ((,alien-var (array (unsigned 8) + ,(constant-form-value size)))) + (let ((,size-var ,(constant-form-value size)) (,var (alien-sap ,alien-var))) (declare (ignorable ,size-var)) ,@body))) @@ -157,16 +158,16 @@ WITH-POINTER-TO-VECTOR-DATA." collect `(,keyword (setf (,fn ptr offset) value))))) (define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0)) - (if (constantp type) - (ecase (eval type) + (if (constant-form-p type) + (ecase (constant-form-value type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(,',fn ,ptr ,offset)))) form)) (define-compiler-macro %mem-set (&whole form value ptr type &optional (offset 0)) - (if (constantp type) + (if (constant-form-p type) (once-only (value) - (ecase (eval type) + (ecase (constant-form-value type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(setf (,',fn ,ptr ,offset) ,value))))) diff --git a/src/cffi-corman.lisp b/src/cffi-corman.lisp index 8a2dfa4dfd02..09b24dc3b91d 100644 --- a/src/cffi-corman.lisp +++ b/src/cffi-corman.lisp @@ -161,7 +161,7 @@ SIZE-VAR is supplied, it will be bound to SIZE during BODY." (:pointer (cref (:handle *) ptr 0)))) ;(define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0)) -; (if (constantp type) +; (if (constant-form-p type) ; `(cref (,(convert-foreign-type type) *) ,ptr ,offset) ; form)) diff --git a/src/cffi-ecl.lisp b/src/cffi-ecl.lisp index 5817a70809d0..212330108b39 100644 --- a/src/cffi-ecl.lisp +++ b/src/cffi-ecl.lisp @@ -212,8 +212,8 @@ WITH-POINTER-TO-VECTOR-DATA." collect (list cffi-type ecl-type string))) (define-compiler-macro %mem-ref (&whole whole ptr type &optional (offset 0)) - (if (and (constantp type) (constantp offset)) - (let ((record (assoc (eval type) +mem-ref-strings+))) + (if (and (constant-form-p type) (constant-form-p offset)) + (let ((record (assoc (constant-form-value type) +mem-ref-strings+))) `(ffi:c-inline (,ptr ,offset) (:pointer-void :cl-index) ; argument types ,(second record) ; return type @@ -222,8 +222,8 @@ WITH-POINTER-TO-VECTOR-DATA." whole)) (define-compiler-macro %mem-set (&whole whole value ptr type &optional (offset 0)) - (if (and (constantp type) (constantp offset)) - (let ((record (assoc (eval type) +mem-set-strings+))) + (if (and (constant-form-p type) (constant-form-p offset)) + (let ((record (assoc (constant-form-value type) +mem-set-strings+))) `(ffi:c-inline (,ptr ,offset ,value) ; arguments with type translated (:pointer-void :cl-index ,(second record)) :void ; does not return anything diff --git a/src/cffi-lispworks.lisp b/src/cffi-lispworks.lisp index 75009a13ff6d..141d19661234 100644 --- a/src/cffi-lispworks.lisp +++ b/src/cffi-lispworks.lisp @@ -162,8 +162,8 @@ be stack allocated if supported by the implementation." ;;; it instead of FLI:DEREFERENCE in the optimizer for %MEM-REF. #+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or)) (define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0)) - (if (constantp type) - (let ((type (eval type))) + (if (constant-form-p type) + (let ((type (constant-form-value type))) (if (or #+(and lispworks-64bit lispworks5.0) (64-bit-type-p type) (eql type :pointer)) (let ((fli-type (convert-foreign-type type)) @@ -179,9 +179,9 @@ be stack allocated if supported by the implementation." ;;; macroexpansion time, when FLI:FOREIGN-TYPED-AREF is not available. #-#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or)) (define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0)) - (if (constantp type) + (if (constant-form-p type) (let ((ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off))) - (type (convert-foreign-type (eval type)))) + (type (convert-foreign-type (constant-form-value type)))) `(fli:dereference ,ptr-form :type ',type)) form)) @@ -195,9 +195,9 @@ be stack allocated if supported by the implementation." ;;; it instead of FLI:DEREFERENCE in the optimizer for %MEM-SET. #+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or)) (define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0)) - (if (constantp type) + (if (constant-form-p type) (once-only (val) - (let ((type (eval type))) + (let ((type (constant-form-value type))) (if (or #+(and lispworks-64bit lispworks5.0) (64-bit-type-p type) (eql type :pointer)) (let ((fli-type (convert-foreign-type type)) @@ -215,10 +215,10 @@ be stack allocated if supported by the implementation." ;;; at macroexpansion time. #-#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or)) (define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0)) - (if (constantp type) + (if (constant-form-p type) (once-only (val) (let ((ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off))) - (type (convert-foreign-type (eval type)))) + (type (convert-foreign-type (constant-form-value type)))) `(setf (fli:dereference ,ptr-form :type ',type) ,val))) form)) diff --git a/src/cffi-mcl.lisp b/src/cffi-mcl.lisp index 1dcf13738608..83ec323862a2 100644 --- a/src/cffi-mcl.lisp +++ b/src/cffi-mcl.lisp @@ -30,7 +30,7 @@ ;;; - integer vector arguments are copied ;;; - return values are not typed ;;; - a shared library must be packaged as a framework and statically loaded -;;; +;;; ;;; on the topic of shared libraries, see ;;; http://developer.apple.com/library/mac/#documentation/DeveloperTools/Conceptual/MachOTopics/1-Articles/loading_code.html ;;; which describes how to package a shared library as a framework. @@ -150,16 +150,16 @@ WITH-POINTER-TO-VECTOR-DATA." collect `(,keyword (setf (,fn ptr offset) value))))) (define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0)) - (if (constantp type) - (ecase (eval type) + (if (constant-form-p type) + (ecase (constant-form-value type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(,',fn ,ptr ,offset)))) form)) (define-compiler-macro %mem-set (&whole form value ptr type &optional (offset 0)) - (if (constantp type) + (if (constant-form-p type) (once-only (value) - (ecase (eval type) + (ecase (constant-form-value type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(setf (,',fn ,ptr ,offset) ,value))))) diff --git a/src/cffi-openmcl.lisp b/src/cffi-openmcl.lisp index 8516807e858d..38b9042df6fb 100644 --- a/src/cffi-openmcl.lisp +++ b/src/cffi-openmcl.lisp @@ -126,16 +126,16 @@ WITH-POINTER-TO-VECTOR-DATA." collect `(,keyword (setf (,fn ptr offset) value))))) (define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0)) - (if (constantp type) - (ecase (eval type) + (if (constant-form-p type) + (ecase (constant-form-value type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(,',fn ,ptr ,offset)))) form)) (define-compiler-macro %mem-set (&whole form value ptr type &optional (offset 0)) - (if (constantp type) + (if (constant-form-p type) (once-only (value) - (ecase (eval type) + (ecase (constant-form-value type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(setf (,',fn ,ptr ,offset) ,value))))) diff --git a/src/cffi-sbcl.lisp b/src/cffi-sbcl.lisp index af097cff05a4..23dbf5586b52 100644 --- a/src/cffi-sbcl.lisp +++ b/src/cffi-sbcl.lisp @@ -112,10 +112,11 @@ SIZE-VAR is supplied, it will be bound to SIZE during BODY." (unless size-var (setf size-var (gensym "SIZE"))) ;; If the size is constant we can stack-allocate. - (if (constantp size) + (if (constant-form-p size) (let ((alien-var (gensym "ALIEN"))) - `(with-alien ((,alien-var (array (unsigned 8) ,(eval size)))) - (let ((,size-var ,(eval size)) + `(with-alien ((,alien-var (array (unsigned 8) + ,(constant-form-value size)))) + (let ((,size-var ,(constant-form-value size)) (,var (alien-sap ,alien-var))) (declare (ignorable ,size-var)) ,@body))) @@ -164,16 +165,16 @@ WITH-POINTER-TO-VECTOR-DATA." collect `(,keyword (setf (,fn ptr offset) value))))) (define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0)) - (if (constantp type) - (ecase (eval type) + (if (constant-form-p type) + (ecase (constant-form-value type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(,',fn ,ptr ,offset)))) form)) (define-compiler-macro %mem-set (&whole form value ptr type &optional (offset 0)) - (if (constantp type) + (if (constant-form-p type) (once-only (value) - (ecase (eval type) + (ecase (constant-form-value type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(setf (,',fn ,ptr ,offset) ,value))))) diff --git a/src/cffi-scl.lisp b/src/cffi-scl.lisp index 524e93d2dd9c..96f984c9c66a 100644 --- a/src/cffi-scl.lisp +++ b/src/cffi-scl.lisp @@ -88,9 +88,10 @@ (unless size-var (setf size-var (gensym (symbol-name '#:size)))) ;; If the size is constant we can stack-allocate. - (cond ((constantp size) + (cond ((constant-form-p size) (let ((alien-var (gensym (symbol-name '#:alien)))) - `(with-alien ((,alien-var (array (unsigned 8) ,(eval size)))) + `(with-alien ((,alien-var (array (unsigned 8) + ,(constant-form-value size)))) (let ((,size-var ,size) (,var (alien-sap ,alien-var))) (declare (ignorable ,size-var)) @@ -153,16 +154,16 @@ collect `(,keyword (setf (,fn ptr offset) value))))) (define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0)) - (if (constantp type) - (ecase (eval type) + (if (constant-form-p type) + (ecase (constant-form-value type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(,',fn ,ptr ,offset)))) form)) (define-compiler-macro %mem-set (&whole form value ptr type &optional (offset 0)) - (if (constantp type) + (if (constant-form-p type) (once-only (value) - (ecase (eval type) + (ecase (constant-form-value type) ,@(loop for (keyword fn) in pairs collect `(,keyword `(setf (,',fn ,ptr ,offset) ,value)))))