X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=b37beaf0015e43266207bec1668317cdaaa4a84d;hb=6ddaf294e5a7e3b1792ed1d9c342894c38538773;hp=92965bfdb89d2fdcadf900a1ead217d54c40ec63;hpb=3a5eefac8a65dfd36729031f0a9b9dd8c022b7f2;p=sbcl.git diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 92965bf..b37beaf 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -128,7 +128,7 @@ (when (or force-p (ctor-class ctor)) (setf (ctor-class ctor) nil) (setf (funcallable-instance-fun ctor) - #'(instance-lambda (&rest args) + #'(lambda (&rest args) (install-optimized-constructor ctor) (apply ctor args))) (setf (%funcallable-instance-info ctor 1) @@ -245,15 +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) - (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)) @@ -306,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)) @@ -331,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 @@ -351,7 +345,7 @@ (defun fallback-generator (ctor ii-methods si-methods) (declare (ignore ii-methods si-methods)) - `(instance-lambda ,(make-ctor-parameter-list ctor) + `(lambda ,(make-ctor-parameter-list ctor) ;; The CTOR MAKE-INSTANCE optimization only kicks in when the ;; first argument to MAKE-INSTANCE is a constant symbol: by ;; calling it with a class, as here, we inhibit the optimization, @@ -360,11 +354,14 @@ (make-instance ,(ctor-class ctor) ,@(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) - `(instance-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 @@ -413,9 +410,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) @@ -496,7 +495,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 @@ -577,22 +581,34 @@ `(setf (clos-slots-ref .slots. ,i) ',(eval 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) ',(eval 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 `',(eval 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.