(defmethod initialize-internal-slot-functions ((slotd
effective-slot-definition))
(let* ((name (slot-value slotd 'name))
- (class (slot-value slotd 'class)))
+ (class (slot-value slotd '%class)))
(let ((table (or (gethash name *name->class->slotd-table*)
(setf (gethash name *name->class->slotd-table*)
(make-hash-table :test 'eq :size 5)))))
(writer '(setf slot-value-using-class))
(boundp 'slot-boundp-using-class)))
(gf (gdefinition gf-name)))
- (compute-slot-accessor-info slotd type gf)))
- (initialize-internal-slot-gfs name)))
+ (compute-slot-accessor-info slotd type gf)))))
;;; CMUCL (Gerd PCL 2003-04-25) comment:
;;;
(defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
type gf)
(let* ((name (slot-value slotd 'name))
- (class (slot-value slotd 'class))
+ (class (slot-value slotd '%class))
(old-slotd (find-slot-definition class name))
(old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
(multiple-value-bind (function std-p)
slot-names
&key)
(declare (ignore slot-names))
- (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
+ (setf (slot-value specl '%type) `(class-eq ,(specializer-class specl))))
(defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
(declare (ignore slot-names))
- (setf (slot-value specl 'type)
+ (setf (slot-value specl '%type)
`(eql ,(specializer-object specl)))
(setf (info :type :translator specl)
(constantly (make-member-type :members (list (specializer-object specl))))))
(set-class-type-translation class name)
class))
-(defmethod class-predicate-name ((class t))
- 'constantly-nil)
-
(defun fix-super (s)
(cond ((classp s) s)
((not (legal-class-name-p s))
\f
(defmethod shared-initialize :after
- ((class std-class)
- slot-names
- &key (direct-superclasses nil direct-superclasses-p)
- (direct-slots nil direct-slots-p)
- (direct-default-initargs nil direct-default-initargs-p)
- (predicate-name nil predicate-name-p))
+ ((class std-class) slot-names &key
+ (direct-superclasses nil direct-superclasses-p)
+ (direct-slots nil direct-slots-p)
+ (direct-default-initargs nil direct-default-initargs-p))
(cond (direct-superclasses-p
(setq direct-superclasses
(or direct-superclasses
(push (cons name value) collect))
(push old collect)))))
(nreverse collect)))
- (setq predicate-name (if predicate-name-p
- (setf (slot-value class 'predicate-name)
- (car predicate-name))
- (or (slot-value class 'predicate-name)
- (setf (slot-value class 'predicate-name)
- (make-class-predicate-name (class-name
- class))))))
(add-direct-subclasses class direct-superclasses)
- (make-class-predicate class predicate-name)
(update-class class nil)
(do* ((slots (slot-value class 'slots) (cdr slots))
(dupes nil))
(declare (ignore slot-names name))
;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not,
;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.)
- (setf (slot-value class 'type) `(class ,class))
+ (setf (slot-value class '%type) `(class ,class))
(setf (slot-value class 'class-eq-specializer)
(make-instance 'class-eq-specializer :class class)))
&key direct-slots direct-superclasses)
(declare (ignore slot-names))
(let ((classoid (find-classoid (class-name class))))
- (with-slots (wrapper class-precedence-list cpl-available-p
- prototype predicate-name
- (direct-supers direct-superclasses))
+ (with-slots (wrapper %class-precedence-list cpl-available-p
+ prototype (direct-supers direct-superclasses))
class
(setf (slot-value class 'direct-slots)
(mapcar (lambda (pl) (make-direct-slotd class pl))
(setf (classoid-pcl-class classoid) class)
(setq direct-supers direct-superclasses)
(setq wrapper (classoid-layout classoid))
- (setq class-precedence-list (compute-class-precedence-list class))
+ (setq %class-precedence-list (compute-class-precedence-list class))
(setq cpl-available-p t)
(add-direct-subclasses class direct-superclasses)
- (setq predicate-name (make-class-predicate-name (class-name class)))
- (make-class-predicate class predicate-name)
(setf (slot-value class 'slots) (compute-slots class))))
;; Comment from Gerd's PCL, 2003-05-15:
;;
(compute-effective-slot-definition
class (slot-definition-name dslotd) (list dslotd)))
(class-direct-slots superclass)))
- (reverse (slot-value class 'class-precedence-list))))
+ (reverse (slot-value class '%class-precedence-list))))
(defmethod compute-slots :around ((class condition-class))
(let ((eslotds (call-next-method)))
(sb-kernel::compiler-layout-or-lose (dd-name dd))))))
(defmethod shared-initialize :after
- ((class structure-class)
- slot-names
- &key (direct-superclasses nil direct-superclasses-p)
+ ((class structure-class) slot-names &key
+ (direct-superclasses nil direct-superclasses-p)
(direct-slots nil direct-slots-p)
- direct-default-initargs
- (predicate-name nil predicate-name-p))
+ direct-default-initargs)
(declare (ignore slot-names direct-default-initargs))
(if direct-superclasses-p
(setf (slot-value class 'direct-superclasses)
(setf (slot-value class 'defstruct-constructor)
(make-defstruct-allocation-function class)))
(add-direct-subclasses class direct-superclasses)
- (setf (slot-value class 'class-precedence-list)
+ (setf (slot-value class '%class-precedence-list)
(compute-class-precedence-list class))
(setf (slot-value class 'cpl-available-p) t)
(setf (slot-value class 'slots) (compute-slots class))
(setf (slot-value class 'wrapper) (classoid-layout lclass)))
(setf (slot-value class 'finalized-p) t)
(update-pv-table-cache-info class)
- (setq predicate-name (if predicate-name-p
- (setf (slot-value class 'predicate-name)
- (car predicate-name))
- (or (slot-value class 'predicate-name)
- (setf (slot-value class 'predicate-name)
- (make-class-predicate-name
- (class-name class))))))
- (make-class-predicate class predicate-name)
(add-slot-accessors class direct-slots)))
(defmethod direct-slot-definition-class ((class structure-class) &rest initargs)
;; comment from the old CMU CL sources:
;; Need to have the cpl setup before update-lisp-class-layout
;; is called on CMU CL.
- (setf (slot-value class 'class-precedence-list) cpl)
+ (setf (slot-value class '%class-precedence-list) cpl)
(setf (slot-value class 'cpl-available-p) t)
(force-cache-flushes class))
(progn
- (setf (slot-value class 'class-precedence-list) cpl)
+ (setf (slot-value class '%class-precedence-list) cpl)
(setf (slot-value class 'cpl-available-p) t)))
(update-class-can-precede-p cpl))
;; do if we find that said user has added a slot
;; with the same name as another slot...
(cell (or (assq name (class-slot-cells from-class))
- (setf (class-slot-cells from-class)
- (cons (cons name +slot-unbound+)
- (class-slot-cells from-class))))))
+ (let ((c (cons name +slot-unbound+)))
+ (push c (class-slot-cells from-class))
+ c))))
(aver (consp cell))
(if (eq +slot-unbound+ (cdr cell))
;; We may have inherited an initfunction
(slot-definition-name dslotd)
(list dslotd)))
(class-direct-slots superclass)))
- (reverse (slot-value class 'class-precedence-list))))
+ (reverse (slot-value class '%class-precedence-list))))
(defmethod compute-slots :around ((class structure-class))
(let ((eslotds (call-next-method)))