Changeset 7946

Timestamp:

Dec 25, 2007, 11:56:38 PM (17 years ago)

Author:

Gary Byers

Message:

Maintain CPL in wrapper ...
Slot type-predicates can be NULL (instead of/interpreted as #'TRUE).
Trust TYPEP/REQUIRE-TYPE a little more in optimized make-instance.

File:

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

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

@@ -599 +599 @@
             (class-finalized-p class)
             (not (class-has-a-forward-referenced-superclass-p class)))
-    (update-cpl class (compute-class-precedence-list  class))
-    ;;; This -should- be made to work for structure classes
-    (update-slots class (compute-slots class))
-    (setf (%class-default-initargs class) (compute-default-initargs class))
-    (%flush-initargs-caches class)
-    )
+    (let* ((cpl (update-cpl class (compute-class-precedence-list  class))))
+      ;; This -should- be made to work for structure classes
+      (update-slots class (compute-slots class))
+      (setf (%class-default-initargs class) (compute-default-initargs class))
+      (%flush-initargs-caches class)
+      (let* ((wrapper (%class-own-wrapper class)))
+        (when wrapper
+          (setf (%wrapper-cpl wrapper) cpl)))))
   (unless finalizep
     (dolist (sub (%class-direct-subclasses class))
@@ -1103 +1105 @@
                  (:name slot-id :initform nil :initfunction ,#'false
                   :readers (slot-definition-slot-id))
-                 (:name type-predicate :initform #'true
-                  :initfunction ,#'(lambda () #'true)
+                 (:name type-predicate :initform nil
+                  :initfunction ,#'false
                   :readers (slot-definition-predicate))
                  )
@@ -1192 +1194 @@
             (add-direct-subclass c class)))
         (setf (%class.local-supers class) new-supers)))
-    (unless (%class-own-wrapper class)
-      (setf (%class-own-wrapper class) (%cons-wrapper class)))
-    (update-cpl class (compute-cpl class))))
+    (let* ((wrapper (or (%class-own-wrapper class)
+                        (setf (%class-own-wrapper class) (%cons-wrapper class))))
+           (cpl (compute-cpl class)))
+      (setf (%wrapper-cpl wrapper) cpl))))
               
 
@@ -1716 +1719 @@
                  ;; Typecheck the new-value, then call
                  ;; (SETF SLOT-VALUE-USING-CLASS)
-                 (unless (funcall predicate new-value)
+                 (unless (or (null predicate)
+                             (funcall predicate new-value))
                    (error 'bad-slot-type-from-initarg
                           :slot-definition slotd
@@ -1736 +1740 @@
                    (if initfunction
                      (let* ((newval (funcall initfunction)))
-                       (unless (funcall predicate newval)
+                       (unless (or (null predicate)
+                                   (funcall predicate newval))
                          (error 'bad-slot-type-from-initform
                                 :slot-definition slotd
@@ -2034 +2039 @@
 
 
+
+
 ;;; Return a lambda form or NIL.
 (defun make-instantiate-lambda-for-class-cell (cell)
@@ -2061 +2068 @@
                    (if (null *typecheck-slots-in-optimized-make-instance*)
                      form
-                     (let* ((ctype (ignore-errors (specifier-type type))))
-                       (if (or (null ctype)
-                               (eq ctype *universal-type*)
-                               (typep ctype 'unknown-ctype))
-                         form
-                         (if spvar
-                           `(if ,spvar
-                             (require-type ,form ',type)
-                             (%slot-unbound-marker))
-                           `(require-type ,form ',type)))))))
+                     (if spvar
+                       `(if ,spvar
+                         (require-type ,form ',type)
+                         (%slot-unbound-marker))
+                       `(require-type ,form ',type)))))
             (dolist (slot slotds)
               (let* ((initarg (car (slot-definition-initargs slot)))