Changeset 7946


Ignore:
Timestamp:
Dec 26, 2007, 7:56:38 AM (12 years ago)
Author:
gb
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:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/l1-clos.lisp

    r7923 r7946  
    599599            (class-finalized-p class)
    600600            (not (class-has-a-forward-referenced-superclass-p class)))
    601     (update-cpl class (compute-class-precedence-list  class))
    602     ;;; This -should- be made to work for structure classes
    603     (update-slots class (compute-slots class))
    604     (setf (%class-default-initargs class) (compute-default-initargs class))
    605     (%flush-initargs-caches class)
    606     )
     601    (let* ((cpl (update-cpl class (compute-class-precedence-list  class))))
     602      ;; This -should- be made to work for structure classes
     603      (update-slots class (compute-slots class))
     604      (setf (%class-default-initargs class) (compute-default-initargs class))
     605      (%flush-initargs-caches class)
     606      (let* ((wrapper (%class-own-wrapper class)))
     607        (when wrapper
     608          (setf (%wrapper-cpl wrapper) cpl)))))
    607609  (unless finalizep
    608610    (dolist (sub (%class-direct-subclasses class))
     
    11031105                 (:name slot-id :initform nil :initfunction ,#'false
    11041106                  :readers (slot-definition-slot-id))
    1105                  (:name type-predicate :initform #'true
    1106                   :initfunction ,#'(lambda () #'true)
     1107                 (:name type-predicate :initform nil
     1108                  :initfunction ,#'false
    11071109                  :readers (slot-definition-predicate))
    11081110                 )
     
    11921194            (add-direct-subclass c class)))
    11931195        (setf (%class.local-supers class) new-supers)))
    1194     (unless (%class-own-wrapper class)
    1195       (setf (%class-own-wrapper class) (%cons-wrapper class)))
    1196     (update-cpl class (compute-cpl class))))
     1196    (let* ((wrapper (or (%class-own-wrapper class)
     1197                        (setf (%class-own-wrapper class) (%cons-wrapper class))))
     1198           (cpl (compute-cpl class)))
     1199      (setf (%wrapper-cpl wrapper) cpl))))
    11971200             
    11981201
     
    17161719                 ;; Typecheck the new-value, then call
    17171720                 ;; (SETF SLOT-VALUE-USING-CLASS)
    1718                  (unless (funcall predicate new-value)
     1721                 (unless (or (null predicate)
     1722                             (funcall predicate new-value))
    17191723                   (error 'bad-slot-type-from-initarg
    17201724                          :slot-definition slotd
     
    17361740                   (if initfunction
    17371741                     (let* ((newval (funcall initfunction)))
    1738                        (unless (funcall predicate newval)
     1742                       (unless (or (null predicate)
     1743                                   (funcall predicate newval))
    17391744                         (error 'bad-slot-type-from-initform
    17401745                                :slot-definition slotd
     
    20342039
    20352040
     2041
     2042
    20362043;;; Return a lambda form or NIL.
    20372044(defun make-instantiate-lambda-for-class-cell (cell)
     
    20612068                   (if (null *typecheck-slots-in-optimized-make-instance*)
    20622069                     form
    2063                      (let* ((ctype (ignore-errors (specifier-type type))))
    2064                        (if (or (null ctype)
    2065                                (eq ctype *universal-type*)
    2066                                (typep ctype 'unknown-ctype))
    2067                          form
    2068                          (if spvar
    2069                            `(if ,spvar
    2070                              (require-type ,form ',type)
    2071                              (%slot-unbound-marker))
    2072                            `(require-type ,form ',type)))))))
     2070                     (if spvar
     2071                       `(if ,spvar
     2072                         (require-type ,form ',type)
     2073                         (%slot-unbound-marker))
     2074                       `(require-type ,form ',type)))))
    20732075            (dolist (slot slotds)
    20742076              (let* ((initarg (car (slot-definition-initargs slot)))
Note: See TracChangeset for help on using the changeset viewer.