Switch compiler macros to CONSTANT-FORM-VALUE instead of CL:EVAL

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))
 

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

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)))))

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))
 

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

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))
 

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)))))

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)))))

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)))))

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)))))

src/early-types.lisp

@@ -634,24 +634,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)

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))))