X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=6db57f9e5929842455a7a8d32c1e1ae1cad6f5f1;hb=8bcffb407835ff680d5ee2ba1f7ce97839bbae3e;hp=c926918dffa930edf670cfd15fb4b7570a73d1fe;hpb=3a2e34d8ed1293f2cecb5c2c6ea359b622e3f4f8;p=sbcl.git diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index c926918..6db57f9 100644 --- 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,17 +245,9 @@ (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. - (eval `(function ,(constructor-function-form ctor)))))) + (multiple-value-bind (form locations names) + (constructor-function-form ctor) + (apply (compile nil `(lambda ,names ,form)) locations))))) (defun constructor-function-form (ctor) (let* ((class (ctor-class ctor)) @@ -308,7 +300,7 @@ ;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up ;; together with the system-defined ones in what ;; COMPUTE-APPLICABLE-METHODS returns. - (or (and (not (structure-class-p class)) + (if (and (not (structure-class-p class)) (not (condition-class-p class)) (null (cdr make-instance-methods)) (null (cdr allocate-instance-methods)) @@ -333,8 +325,8 @@ ;; SLOT-BOUNDP-USING-CLASS), so if there are non-standard ;; applicable methods we can't shortcircuit them. (every (lambda (x) (= (length x) 1)) setf-svuc-slots-methods) - (every (lambda (x) (= (length x) 1)) sbuc-slots-methods) - (optimizing-generator ctor ii-methods si-methods)) + (every (lambda (x) (= (length x) 1)) sbuc-slots-methods)) + (optimizing-generator ctor ii-methods si-methods) (fallback-generator ctor ii-methods si-methods)))) (defun around-or-nonstandard-primary-method-p @@ -359,14 +351,18 @@ ;; 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 (body before-method-p) + (multiple-value-bind (locations names body before-method-p) (fake-initialization-emf ctor ii-methods si-methods) - `(lambda ,(make-ctor-parameter-list ctor) + (values + `(lambda ,(make-ctor-parameter-list ctor) (declare #.*optimize-speed*) - ,(wrap-in-allocate-forms ctor body before-method-p)))) + ,(wrap-in-allocate-forms ctor body before-method-p)) + locations + names))) ;;; Return a form wrapped around BODY that allocates an instance ;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run @@ -415,9 +411,11 @@ (declare (ignore si-primary)) (aver (and (null ii-around) (null si-around))) (let ((initargs (ctor-initargs ctor))) - (multiple-value-bind (bindings vars defaulting-initargs body) + (multiple-value-bind (locations names bindings vars defaulting-initargs body) (slot-init-forms ctor (or ii-before si-before)) (values + locations + names `(let ,bindings (declare (ignorable ,@vars)) (let (,@(when (or ii-before ii-after) @@ -498,7 +496,12 @@ (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.))) (if (array-in-bounds-p ps i) (aref ps i) - (format-symbol *pcl-package* ".D~D." i))))) + (format-symbol *pcl-package* ".D~D." i)))) + (location-var-name (i) + (let ((ls #(.l0. .l1. .l2. .l3. .l4. .l5.))) + (if (array-in-bounds-p ls i) + (aref ls i) + (format-symbol *pcl-package* ".L~D." i))))) ;; Loop over supplied initargs and values and record which ;; instance and class slots they initialize. (loop for (key value) on initargs by #'cddr @@ -575,26 +578,39 @@ `(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)))))) - (class-init-forms - (loop for (location type value) in class-inits collect - `(setf (cdr ',location) - ,(ecase type - (constant `',(eval value)) - ((param var) `,value) - (initfn `(funcall ,value))))))) - (multiple-value-bind (vars bindings) - (loop for (var . initfn) in (nreverse default-inits) - collect var into vars - collect `(,var (funcall ,initfn)) into bindings - finally (return (values vars bindings))) - (values bindings vars (nreverse defaulting-initargs) - `(,@(delete nil instance-init-forms) - ,@class-init-forms))))))) + `(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 + ;; be bound to the location. + (multiple-value-bind (names locations class-init-forms) + (loop for (location type value) in class-inits + for i upfrom 0 + for name = (location-var-name i) + collect name into names + collect location into locations + collect `(setf (cdr ,name) + ,(case type + (constant `',(constant-form-value value)) + ((param var) `,value) + (initfn `(funcall ,value)))) + into class-init-forms + finally (return (values names locations class-init-forms))) + (multiple-value-bind (vars bindings) + (loop for (var . initfn) in (nreverse default-inits) + collect var into vars + collect `(,var (funcall ,initfn)) into bindings + finally (return (values vars bindings))) + (values locations names + bindings vars + (nreverse defaulting-initargs) + `(,@(delete nil instance-init-forms) + ,@class-init-forms)))))))) ;;; Return an alist of lists (KEY LOCATION ...) telling, for each ;;; key in INITKEYS, which locations the initarg initializes.