Changeset 8028

Timestamp:

Jan 8, 2008, 12:16:40 PM (17 years ago)

Author:

Bill St. Clair

Message:

make-instantiate-lambda-for-class-cell, the function that generates
the code for optimize-make-instnace-for-class-name, now generates
proper code for slots with multiple initargs and for class slots. It
used to process only the first initarg, and it used to initialize
class slots only if they were unbound. Class slots are supposed to be
set from the :initial-value form only if they are unbound, but the
CLOS specification says to set them from initargs unconditionally.

File:

• branches/working-0711/ccl/level-1/l1-clos.lisp (modified) (5 diffs)

branches/working-0711/ccl/level-1/l1-clos.lisp

@@ -2055 +2055 @@
                           t))
                       (null (cdr (compute-applicable-methods #'shared-initialize (list proto t)))))))
-      (let* ((slotds (sort (copy-list (class-slots class)) #'(lambda (x y) (if (consp x) x (if (consp y) y (< x y)))) :key #'slot-definition-location))
+      (let* ((slotds (sort (copy-list (class-slots class))
+                           #'(lambda (x y)
+                               (if (consp x) x (if (consp y) y (< x y))))
+                           :key #'slot-definition-location))
              (default-initargs (class-default-initargs class)))
         (collect ((keys)
                   (binds)
+                  (class-binds)
                   (ignorable)
                   (class-slot-inits)
@@ -2065 +2069 @@
           (flet ((generate-type-check (form type &optional spvar)
                    (if (or (null *typecheck-slots-in-optimized-make-instance*)
-                           (eq form t))
+                           (eq type t))
                      form
                      (if spvar
@@ -2073 +2077 @@
                        `(require-type ,form ',type)))))
             (dolist (slot slotds)
-              (let* ((initarg (car (slot-definition-initargs slot)))
+              (let* ((initargs (slot-definition-initargs slot))
                      (initfunction (slot-definition-initfunction slot))
                      (initform (slot-definition-initform slot))
                      (location (slot-definition-location slot))
+                     (location-var nil)
+                     (one-initarg-p (null (cdr initargs)))
                      (name (slot-definition-name slot))
-                     (spvar nil)
-                     (type (slot-definition-type slot))
-                     (initial-value-form (if initfunction
-                                           (if (self-evaluating-p initform)
-                                             initform
-                                             `(funcall ,initfunction))
+                     (type (slot-definition-type slot)))
+                (when initfunction
+                  (when (consp location)
+                    (setq location-var (gensym "LOCATION"))
+                    (class-binds `(,location-var
+                                   (load-time-value
+                                    (slot-definition-location ',slot)))))
+                  (setq initform
+                        (if (self-evaluating-p initform)
+                            initform
+                            `(funcall ,initfunction))))
+                (cond ((null initargs)
+                       (let ((initial-value-form
+                              (if initfunction
+                                  (generate-type-check initform type)
+                                  `(%slot-unbound-marker))))
+                         (if (consp location)
+                             (when initfunction
+                                 (class-slot-inits
+                                  `(when (eq (%slot-unbound-marker) (cdr ,location-var))
+                                     (setf (cdr ,location-var) ,initial-value-form))))
+                             (forms initial-value-form))))
+                      (t (collect ((cond-clauses))
+                           (let ((last-cond-clause nil))
+                             (dolist (initarg initargs)
+                               (let* ((spvar nil)
+                                      (name (if one-initarg-p
+                                                name
+                                                (gensym (string name))))
+                                      (initial-value-form
+                                       (if (and initfunction
+                                                one-initarg-p
+                                                (atom location))
+                                           initform
                                            (progn
                                              (when initarg
@@ -2089 +2123 @@
                                                             (concatenate
                                                              'string
-                                                             (string name)
+                                                             (string initarg)
                                                              "-P"))))
-                                             `(%slot-unbound-marker)))))
-                (when spvar (ignorable spvar))
-                (if initarg
-                  (progn
-                    (keys (list*
-                           (list initarg name)
-                           (let* ((default (assq initarg default-initargs)))
-                             (if default
-                               (destructuring-bind (form function)
-                                   (cdr default)
-                                 (if (self-evaluating-p form)
-                                   form
-                                   `(funcall ,function)))
-                               initial-value-form))
-                           (if spvar (list spvar))))
-                    (if (consp location)
-                      (class-slot-inits `(unless (eq ,name (%slot-unbound-marker)) (when (eq (%slot-unbound-marker) (cdr ',location))(setf (cdr ',location) ,(generate-type-check name type)))))
-                      (forms `,(generate-type-check name type spvar))))
-                  (progn
-                    (when initfunction
-                      (setq initial-value-form (generate-type-check initial-value-form type)))
-                    (if (consp location)
-                      (if initfunction
-                        (class-slot-inits `(when (eq (%slot-unbound-marker) (cdr ',location))(setf (cdr ',location) ,initial-value-form))))
-                    
-                      (forms initial-value-form)))))))
+                                             (and one-initarg-p
+                                                  (atom location)
+                                                  (if initfunction
+                                                      initform
+                                                      `(%slot-unbound-marker))))))
+                                      (default (assq initarg default-initargs)))
+                                 (when spvar (ignorable spvar))
+                                 (when default
+                                   (destructuring-bind (form function)
+                                       (cdr default)
+                                     (setq default
+                                           (if (self-evaluating-p form)
+                                               form
+                                               `(funcall ,function)))))
+                                 (keys (list*
+                                        (list initarg name)
+                                        (if (and default one-initarg-p (atom location))
+                                            default
+                                            initial-value-form)
+                                        (if spvar (list spvar))))
+                                 (if one-initarg-p
+                                     (if (consp location)
+                                         (class-slot-inits
+                                          `(if ,spvar
+                                               (setf (cdr ,location-var)
+                                                     ,(generate-type-check
+                                                       name type))
+                                               ,(if default
+                                                    `(setf (cdr ,location-var)
+                                                           ,(generate-type-check
+                                                             default type))
+                                                    (when initfunction
+                                                      `(when (eq (%slot-unbound-marker)
+                                                                 (cdr ,location-var))
+                                                         (setf (cdr ,location-var)
+                                                               ,(generate-type-check
+                                                                 initform type)))))))
+                                         (forms `,(generate-type-check name type spvar)))
+                                     (progn (cond-clauses `(,spvar ,name))
+                                            (when (and default (null last-cond-clause))
+                                              (setq last-cond-clause
+                                                    `(t ,default)))))))
+                             (when (cond-clauses)
+                               (when last-cond-clause
+                                 (cond-clauses last-cond-clause))
+                               (cond ((atom location)
+                                      (unless last-cond-clause
+                                        (cond-clauses `(t ,initform)))
+                                      (forms (generate-type-check
+                                              `(cond ,@(cond-clauses))
+                                              type)))
+                                     (t
+                                      (let ((initform-p-var
+                                             (unless last-cond-clause
+                                               (make-symbol "INITFORM-P")))
+                                            (value-var (make-symbol "VALUE")))
+                                        (unless last-cond-clause
+                                          (cond-clauses
+                                           `(t (setq ,initform-p-var t)
+                                               ,(if initfunction
+                                                    initform
+                                                    `(%slot-unbound-marker)))))
+                                        (class-slot-inits
+                                         `(let* (,@(and initform-p-var
+                                                        (list `(,initform-p-var nil)))
+                                                 (,value-var
+                                                  ,(generate-type-check
+                                                    `(cond ,@(cond-clauses)) type)))
+                                            (when
+                                                ,(if initform-p-var
+                                                     `(or (null ,initform-p-var)
+                                                          (and (eq (cdr ,location-var)
+                                                                   (%slot-unbound-marker))
+                                                               (not (eq ,value-var
+                                                                        (%slot-unbound-marker)))))
+                                                     t)
+                                                (setf (cdr ,location-var) ,value-var)))))))))))))))
           (let* ((cell (make-symbol "CLASS-CELL"))
                  (args (make-symbol "ARGS"))
@@ -2130 +2215 @@
               (declare (ignorable ,@(ignorable)))
               ,@(when after-methods `((declare (dynamic-extent ,args))))
-              ,@(class-slot-inits)
+              (let (,@(class-binds))
+                ,@(class-slot-inits))
               (let* (,@(binds))
                 (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance)