[Sbcl-commits] CVS: sbcl/src/pcl boot.lisp,1.108,1.109 ctor.lisp,1.24,1.25 defcombin.lisp,1.33,1.34 fngen.lisp,1.12,1.13 macros.lisp,1.25,1.26 slots-boot.lisp,1.25,1.26 slots.lisp,1.22,1.23 vector.lisp,1.36,1.37

[Nikodemus S. <de...@us...>]

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2812/src/pcl

Modified Files:
	boot.lisp ctor.lisp defcombin.lisp fngen.lisp macros.lisp 
	slots-boot.lisp slots.lisp vector.lisp 
Log Message:
0.9.10.4: better CONSTANTP
 * Recognizes constant argument calls to foldable functions and also
    deals with some simple special forms like.
 * Replace a ton of EVAL calls with CONSTANT-FORM-VALUE.



Index: boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v
retrieving revision 1.108
retrieving revision 1.109
diff -u -d -r1.108 -r1.109
--- boot.lisp	13 Feb 2006 15:59:16 -0000	1.108
+++ boot.lisp	27 Feb 2006 13:12:35 -0000	1.109
@@ -406,7 +406,7 @@
                       (if (consp s)
                           (and (eq (car s) 'eql)
                                (constantp (cadr s))
-                               (let ((sv (eval (cadr s))))
+                               (let ((sv (constant-form-value (cadr s))))
                                  (or (interned-symbol-p sv)
                                      (integerp sv)
                                      (and (characterp sv)
@@ -713,7 +713,7 @@
                (constant-value-p (and (null (cdr real-body))
                                       (constantp (car real-body))))
                (constant-value (and constant-value-p
-                                    (eval (car real-body))))
+                                    (constant-form-value (car real-body))))
                (plist (and constant-value-p
                            (or (typep constant-value
                                       '(or number character))
@@ -953,7 +953,7 @@
   ;; broken if RESTP evaluates to a non-self-evaluating form. E.g. if
   ;;   (INVOKE-EFFECTIVE-METHOD-FUNCTION EMF '(ERROR "gotcha") ...)
   ;; then TRACE-EMF-CALL-CALL-INTERNAL might die on a gotcha error.
-  (setq restp (eval restp))
+  (setq restp (constant-form-value restp))
   `(progn
      (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
      (cond ((typep ,emf 'fast-method-call)

Index: ctor.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/ctor.lisp,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -d -r1.24 -r1.25
--- ctor.lisp	29 Jan 2006 22:15:27 -0000	1.24
+++ ctor.lisp	27 Feb 2006 13:12:35 -0000	1.25
@@ -86,7 +86,7 @@
 
 (defun constant-symbol-p (form)
   (and (constantp form)
-       (let ((constant (eval form)))
+       (let ((constant (constant-form-value form)))
          (and (symbolp constant)
               (not (null (symbol-package constant)))))))
 
@@ -183,7 +183,7 @@
              (loop for (key . more) on args by #'cddr do
                      (when (or (null more)
                                (not (constant-symbol-p key))
-                               (eq :allow-other-keys (eval key)))
+                               (eq :allow-other-keys (constant-form-value key)))
                        (return-from make-instance->constructor-call nil)))))
       (check-class)
       (check-args)
@@ -192,7 +192,7 @@
       ;; VALUE-FORMS.
       (multiple-value-bind (initargs value-forms)
           (loop for (key value) on args by #'cddr and i from 0
-                collect (eval key) into initargs
+                collect (constant-form-value key) into initargs
                 if (constantp value)
                   collect value into initargs
                 else
@@ -200,7 +200,7 @@
                   and collect value into value-forms
                 finally
                   (return (values initargs value-forms)))
-        (let* ((class-name (eval class-name))
+        (let* ((class-name (constant-form-value class-name))
                (function-name (make-ctor-function-name class-name initargs)))
           ;; Prevent compiler warnings for calling the ctor.
           (proclaim-as-fun-name function-name)
@@ -578,11 +578,12 @@
                             `(when (eq (clos-slots-ref .slots. ,i)
                                        +slot-unbound+)
                                (setf (clos-slots-ref .slots. ,i)
-                                     ',(eval value)))
+                                     ',(constant-form-value value)))
                             `(setf (clos-slots-ref .slots. ,i)
-                                   ',(eval value))))
+                                   ',(constant-form-value value))))
                        (constant
-                        `(setf (clos-slots-ref .slots. ,i) ',(eval value)))))))
+                        `(setf (clos-slots-ref .slots. ,i)
+                               ',(constant-form-value value)))))))
         ;; we are not allowed to modify QUOTEd locations, so we can't
         ;; generate code like (setf (cdr ',location) arg).  Instead,
         ;; we have to do (setf (cdr .L0.) arg) and arrange for .L0. to
@@ -595,7 +596,7 @@
                   collect location into locations
                   collect `(setf (cdr ,name)
                                  ,(case type
-                                    (constant `',(eval value))
+                                    (constant `',(constant-form-value value))
                                     ((param var) `,value)
                                     (initfn `(funcall ,value))))
                   into class-init-forms

Index: defcombin.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/defcombin.lisp,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -d -r1.33 -r1.34
--- defcombin.lisp	14 Feb 2006 17:15:00 -0000	1.33
+++ defcombin.lisp	27 Feb 2006 13:12:35 -0000	1.34
@@ -343,7 +343,8 @@
                           :format-arguments (list ',name))))
                     required-checks))
             (loop (unless (and (constantp order)
-                               (neq order (setq order (eval order))))
+                               (neq order (setq order
+                                                (constant-form-value order))))
                     (return t)))
             (push (cond ((eq order :most-specific-first)
                          `(setq ,name (nreverse ,name)))

Index: fngen.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/fngen.lisp,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -d -r1.12 -r1.13
--- fngen.lisp	14 Jul 2005 19:28:18 -0000	1.12
+++ fngen.lisp	27 Feb 2006 13:12:35 -0000	1.13
@@ -60,8 +60,7 @@
           (compute-constants lambda constant-converter)))
 
 (defun default-constantp (form)
-  (and (constantp form)
-       (not (typep (eval form) '(or symbol fixnum)))))
+  (constant-typep form '(not (or symbol fixnum))))
 
 (defun default-test-converter (form)
   (if (default-constantp form)
@@ -75,7 +74,7 @@
 
 (defun default-constant-converter (form)
   (if (default-constantp form)
-      (list (eval form))
+      (list (constant-form-value form))
       nil))
 
 ;;; *FGENS* is a list of all the function generators we have so far. Each

Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/macros.lisp,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- macros.lisp	2 Dec 2005 22:53:04 -0000	1.25
+++ macros.lisp	27 Feb 2006 13:12:35 -0000	1.26
@@ -137,11 +137,10 @@
                                    symbol &optional (errorp t) environment)
   (declare (ignore environment))
   (if (and (constantp symbol)
-           (legal-class-name-p (eval symbol))
+           (legal-class-name-p (setf symbol (constant-form-value symbol)))
            (constantp errorp)
            (member *boot-state* '(braid complete)))
-      (let ((symbol (eval symbol))
-            (errorp (not (null (eval errorp))))
+      (let ((errorp (not (null (constant-form-value errorp))))
             (class-cell (make-symbol "CLASS-CELL")))
         `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
            (or (find-class-cell-class ,class-cell)

Index: slots-boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots-boot.lisp,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- slots-boot.lisp	7 Dec 2005 15:24:41 -0000	1.25
+++ slots-boot.lisp	27 Feb 2006 13:12:35 -0000	1.26
@@ -48,7 +48,7 @@
 
 (defmacro accessor-slot-value (object slot-name)
   (aver (constantp slot-name))
-  (let* ((slot-name (eval slot-name))
+  (let* ((slot-name (constant-form-value slot-name))
          (reader-name (slot-reader-name slot-name)))
     `(let ((.ignore. (load-time-value
                       (ensure-accessor 'reader ',reader-name ',slot-name))))
@@ -60,7 +60,7 @@
   (aver (constantp slot-name))
   (setq object (macroexpand object env))
   (setq slot-name (macroexpand slot-name env))
-  (let* ((slot-name (eval slot-name))
+  (let* ((slot-name (constant-form-value slot-name))
          (bindings (unless (or (constantp new-value) (atom new-value))
                      (let ((object-var (gensym)))
                        (prog1 `((,object-var ,object))
@@ -80,7 +80,7 @@
 
 (defmacro accessor-slot-boundp (object slot-name)
   (aver (constantp slot-name))
-  (let* ((slot-name (eval slot-name))
+  (let* ((slot-name (constant-form-value slot-name))
          (boundp-name (slot-boundp-name slot-name)))
     `(let ((.ignore. (load-time-value
                       (ensure-accessor 'boundp ',boundp-name ',slot-name))))

Index: slots.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- slots.lisp	9 Sep 2005 16:09:51 -0000	1.22
+++ slots.lisp	27 Feb 2006 13:12:35 -0000	1.23
@@ -90,7 +90,7 @@
 
 (define-compiler-macro slot-value (&whole form object slot-name)
   (if (and (constantp slot-name)
-           (interned-symbol-p (eval slot-name)))
+           (interned-symbol-p (constant-form-value slot-name)))
       `(accessor-slot-value ,object ,slot-name)
       form))
 
@@ -105,7 +105,7 @@
 
 (define-compiler-macro set-slot-value (&whole form object slot-name new-value)
   (if (and (constantp slot-name)
-           (interned-symbol-p (eval slot-name)))
+           (interned-symbol-p (constant-form-value slot-name)))
       `(accessor-set-slot-value ,object ,slot-name ,new-value)
       form))
 
@@ -120,7 +120,7 @@
 
 (define-compiler-macro slot-boundp (&whole form object slot-name)
   (if (and (constantp slot-name)
-           (interned-symbol-p (eval slot-name)))
+           (interned-symbol-p (constant-form-value slot-name)))
       `(accessor-slot-boundp ,object ,slot-name)
       form))
 

Index: vector.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/vector.lisp,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -d -r1.36 -r1.37
--- vector.lisp	14 Jul 2005 19:45:43 -0000	1.36
+++ vector.lisp	27 Feb 2006 13:12:35 -0000	1.37
@@ -586,7 +586,7 @@
                  (when (and class-name (not (eq class-name t)))
                    (position parameter-or-nil slots :key #'car))))))
       (if (constantp form)
-          (let ((form (eval form)))
+          (let ((form (constant-form-value form)))
             (if (symbolp form)
                 form
                 *unspecific-arg*))
@@ -630,8 +630,9 @@
 ;;; It is safe for these two functions to be wrong. They just try to
 ;;; guess what the most likely case will be.
 (defun generate-fast-class-slot-access-p (class-form slot-name-form)
-  (let ((class (and (constantp class-form) (eval class-form)))
-        (slot-name (and (constantp slot-name-form) (eval slot-name-form))))
+  (let ((class (and (constantp class-form) (constant-form-value class-form)))
+        (slot-name (and (constantp slot-name-form)
+                        (constant-form-value slot-name-form))))
     (and (eq *boot-state* 'complete)
          (standard-class-p class)
          (not (eq class *the-class-t*)) ; shouldn't happen, though.
@@ -639,8 +640,9 @@
            (and slotd (eq :class (slot-definition-allocation slotd)))))))
 
 (defun skip-fast-slot-access-p (class-form slot-name-form type)
-  (let ((class (and (constantp class-form) (eval class-form)))
-        (slot-name (and (constantp slot-name-form) (eval slot-name-form))))
+  (let ((class (and (constantp class-form) (constant-form-value class-form)))
+        (slot-name (and (constantp slot-name-form)
+                        (constant-form-value slot-name-form))))
     (and (eq *boot-state* 'complete)
          (standard-class-p class)
          (not (eq class *the-class-t*)) ; shouldn't happen, though.