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

Timestamp:

Dec 3, 2007, 9:53:40 PM (13 years ago)

Author:

gb

Message:

Handle class slots in MAKE-INSTANTIATE-LAMBDA-FOR-CLASS-CELL.

File:

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

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

@@ -1878 +1878 @@
                  (and (null (cdr (compute-applicable-methods #'initialize-instance (list proto))))
                       (null (cdr (compute-applicable-methods #'shared-initialize (list proto t)))))))
-      (let* ((slotds (sort (copy-list (class-slots class)) #'< :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)))
         ;; Punt if any slot has multiple initargs
@@ -1886 +1886 @@
           (collect ((keys)
                     (binds)
+                    (class-slot-inits)
                     (forms))
             (dolist (slot slotds)
@@ -1891 +1892 @@
                      (initfunction (slot-definition-initfunction slot))
                      (initform (slot-definition-initform slot))
+                     (location (slot-definition-location slot))
                      (name (slot-definition-name slot))
                      (initial-value-form (if initfunction
@@ -1910 +1912 @@
                                    `(funcall ,function)))
                                initial-value-form))))
-                    (if (eq type t)
-                      (forms name)
+                    (if (consp location)
+                      (class-slot-inits `(when (eq (%slot-unbound-marker) (cdr ',location))(setf (cdr ',location) (require-type ,name ',type))))
                       (forms `(require-type ,name ',type))))
-                  (if (eq type t)
-                    (forms initial-value-form)
+                  (if (consp location)
+                    (class-slot-inits `(when (eq (%slot-unbound-marker) (cdr ',location))(setf (cdr ',location) (require-type ,initial-value-form ',type))))
+                    
                     (forms `(require-type ,initial-value-form ',type))))))
             (let* ((cell (make-symbol "CLASS-CELL"))
@@ -1922 +1925 @@
               (binds `(,instance (gvector :instance 0 (class-cell-extra ,cell) ,slots)))
               `(lambda (,cell &key ,@(keys))
+                ,@(class-slot-inits)
                 (let* (,@(binds))
                   (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance)