0.9.14.12:

[sbcl.git] / src / pcl / ctor.lisp

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 28637cd..6db57f9 100644 (file)
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -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)))))))
 
@@ -109,7 +109,7 @@
 (!defstruct-with-alternate-metaclass ctor
   :slot-names (function-name class-name class initargs)
   :boa-constructor %make-ctor
-  :superclass-name pcl-funcallable-instance
+  :superclass-name function
   :metaclass-name random-pcl-classoid
   :metaclass-constructor make-random-pcl-classoid
   :dd-type funcallable-structure
@@ -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)
@@ -245,16 +245,6 @@
     (setf (ctor-class ctor) class)
     (pushnew ctor (plist-value class 'ctors))
     (setf (funcallable-instance-fun ctor)
-          ;; KLUDGE: Gerd here has the equivalent of (COMPILE NIL
-          ;; (CONSTRUCTOR-FUNCTION-FORM)), but SBCL's COMPILE doesn't
-          ;; deal with INSTANCE-LAMBDA expressions, only with LAMBDA
-          ;; expressions.  The below should be equivalent, since we
-          ;; have a compiler-only implementation.
-          ;;
-          ;; (except maybe for optimization qualities? -- CSR,
-          ;; 2004-07-12)
-          ;;
-          ;; FIXME: INSTANCE-LAMBDA is no more.  We could change this.
           (multiple-value-bind (form locations names)
               (constructor-function-form ctor)
             (apply (compile nil `(lambda ,names ,form)) locations)))))
@@ -361,12 +351,13 @@
      ;; calling it with a class, as here, we inhibit the optimization,
      ;; so removing the possibility of endless recursion.  -- CSR,
      ;; 2004-07-12
-     (make-instance ,(ctor-class ctor) ,@(ctor-initargs ctor))))
+     (make-instance ,(ctor-class ctor)
+      ,@(quote-plist-keys (ctor-initargs ctor)))))
 
 (defun optimizing-generator (ctor ii-methods si-methods)
   (multiple-value-bind (locations names body before-method-p)
       (fake-initialization-emf ctor ii-methods si-methods)
-    (values 
+    (values
      `(lambda ,(make-ctor-parameter-list ctor)
        (declare #.*optimize-speed*)
        ,(wrap-in-allocate-forms ctor body before-method-p))
@@ -587,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
@@ -604,9 +596,9 @@
                   collect location into locations
                   collect `(setf (cdr ,name)
                                  ,(case type
-                                    (constant `',(eval value))
+                                    (constant `',(constant-form-value value))
                                     ((param var) `,value)
-                                    (initfn `(funcall ,value)))) 
+                                    (initfn `(funcall ,value))))
                   into class-init-forms
                   finally (return (values names locations class-init-forms)))
           (multiple-value-bind (vars bindings)
@@ -614,8 +606,8 @@
                     collect var into vars
                     collect `(,var (funcall ,initfn)) into bindings
                     finally (return (values vars bindings)))
-            (values locations names 
-                    bindings vars 
+            (values locations names
+                    bindings vars
                     (nreverse defaulting-initargs)
                     `(,@(delete nil instance-init-forms)
                       ,@class-init-forms))))))))