(declaim (ftype (function (layout sb!xc:class index simple-vector layout-depthoid))
check-layout))
(defun check-layout (layout class length inherits depthoid)
- (assert (eq (layout-class layout) class))
+ (aver (eq (layout-class layout) class))
(when (redefine-layout-warning "current" layout
"compile time" length inherits depthoid)
;; Classic CMU CL had more options here. There are several reasons
(declaim (ftype (function (symbol index simple-vector layout-depthoid) layout)
find-and-init-or-check-layout))
(defun find-and-init-or-check-layout (name length inherits depthoid)
+ (/show0 "entering FIND-AND-INIT-OR-CHECK-LAYOUT")
(let ((layout (find-layout name)))
(init-or-check-layout layout
(or (sb!xc:find-class name nil)
(class-layout (class-layout class))
(subclasses (class-subclasses class)))
- ;; Attempting to register ourselves with a temporary cookie is
- ;; almost certainly a programmer error. (I should know, I did it.)
- ;; -- WHN 19990927
- (assert (not (undefined-class-p class)))
+ ;; Attempting to register ourselves with a temporary undefined
+ ;; class placeholder is almost certainly a programmer error. (I
+ ;; should know, I did it.) -- WHN 19990927
+ (aver (not (undefined-class-p class)))
;; This assertion dates from classic CMU CL. The rationale is
;; probably that calling REGISTER-LAYOUT more than once for the
;; same LAYOUT is almost certainly a programmer error.
- (assert (not (eq class-layout layout)))
+ (aver (not (eq class-layout layout)))
;; Figure out what classes are affected by the change, and issue
;; appropriate warnings and invalidations.
(translation nil :type (or ctype (member nil :initializing))))
(defun make-built-in-class (&rest rest)
(apply #'bare-make-built-in-class
- (rename-keyword-args '((:name :%name)) rest)))
+ (rename-key-args '((:name :%name)) rest)))
;;; FIXME: In CMU CL, this was a class with a print function, but not
;;; necessarily a structure class (e.g. CONDITIONs). In SBCL,
(constructor nil :type (or function null)))
(defun make-structure-class (&rest rest)
(apply #'bare-make-structure-class
- (rename-keyword-args '((:name :%name)) rest)))
+ (rename-key-args '((:name :%name)) rest)))
;;; FUNCALLABLE-STRUCTURE-CLASS is used to represent funcallable
;;; structures, which are used to implement generic functions.
(:constructor bare-make-funcallable-structure-class)))
(defun make-funcallable-structure-class (&rest rest)
(apply #'bare-make-funcallable-structure-class
- (rename-keyword-args '((:name :%name)) rest)))
+ (rename-key-args '((:name :%name)) rest)))
\f
;;;; class namespace
;;; always of the desired class. The second result is any existing
;;; LAYOUT for this name.
(defun insured-find-class (name predicate constructor)
- (declare (function predicate constructor))
+ (declare (type function predicate constructor))
(let* ((old (sb!xc:find-class name nil))
(res (if (and old (funcall predicate old))
old
\f
;;;; CLASS type operations
-(define-type-class sb!xc:class)
+(!define-type-class sb!xc:class)
;;; Simple methods for TYPE= and SUBTYPEP should never be called when
;;; the two classes are equal, since there are EQ checks in those
;;; operations.
-(define-type-method (sb!xc:class :simple-=) (type1 type2)
- (assert (not (eq type1 type2)))
+(!define-type-method (sb!xc:class :simple-=) (type1 type2)
+ (aver (not (eq type1 type2)))
(values nil t))
-(define-type-method (sb!xc:class :simple-subtypep) (class1 class2)
- (assert (not (eq class1 class2)))
+(!define-type-method (sb!xc:class :simple-subtypep) (class1 class2)
+ (aver (not (eq class1 class2)))
(let ((subclasses (class-subclasses class2)))
(if (and subclasses (gethash class1 subclasses))
(values t t)
;;; When finding the intersection of a sealed class and some other
;;; class (not hierarchically related) the intersection is the union
;;; of the currently shared subclasses.
-(defun sealed-class-intersection (sealed other)
+(defun sealed-class-intersection2 (sealed other)
(declare (type sb!xc:class sealed other))
(let ((s-sub (class-subclasses sealed))
(o-sub (class-subclasses other)))
(declare (ignore layout))
(when (gethash subclass o-sub)
(res (specifier-type subclass))))
- (values (res) t))
- (values *empty-type* t))))
+ (res))
+ *empty-type*)))
-;;; If one is a subclass of the other, then that is the intersection,
-;;; but we can only be sure the intersection is otherwise empty if
-;;; they are structure classes, since a subclass of both might be
-;;; defined. If either class is sealed, we can eliminate this
-;;; possibility.
-(define-type-method (sb!xc:class :simple-intersection) (class1 class2)
+(!define-type-method (sb!xc:class :simple-intersection2) (class1 class2)
(declare (type sb!xc:class class1 class2))
- (cond ((eq class1 class2) class1)
+ (cond ((eq class1 class2)
+ class1)
+ ;; If one is a subclass of the other, then that is the
+ ;; intersection.
((let ((subclasses (class-subclasses class2)))
(and subclasses (gethash class1 subclasses)))
- (values class1 t))
+ class1)
((let ((subclasses (class-subclasses class1)))
(and subclasses (gethash class2 subclasses)))
- (values class2 t))
+ class2)
+ ;; Otherwise, we can't in general be sure that the
+ ;; intersection is empty, since a subclass of both might be
+ ;; defined. But we can eliminate it for some special cases.
((or (basic-structure-class-p class1)
(basic-structure-class-p class2))
- (values *empty-type* t))
+ ;; No subclass of both can be defined.
+ *empty-type*)
((eq (class-state class1) :sealed)
- (sealed-class-intersection class1 class2))
+ ;; checking whether a subclass of both can be defined:
+ (sealed-class-intersection2 class1 class2))
((eq (class-state class2) :sealed)
- (sealed-class-intersection class2 class1))
+ ;; checking whether a subclass of both can be defined:
+ (sealed-class-intersection2 class2 class1))
(t
- (values class1 nil))))
+ ;; uncertain, since a subclass of both might be defined
+ nil)))
-(define-type-method (sb!xc:class :unparse) (type)
+(!define-type-method (sb!xc:class :unparse) (type)
(class-proper-name type))
\f
;;;; PCL stuff
(:constructor bare-make-random-pcl-class)))
(defun make-standard-class (&rest rest)
(apply #'bare-make-standard-class
- (rename-keyword-args '((:name :%name)) rest)))
+ (rename-key-args '((:name :%name)) rest)))
(defun make-random-pcl-class (&rest rest)
(apply #'bare-make-random-pcl-class
- (rename-keyword-args '((:name :%name)) rest)))
+ (rename-key-args '((:name :%name)) rest)))
\f
;;;; built-in classes
array sequence
generic-string generic-vector generic-array mutable-sequence
mutable-collection generic-sequence collection))
+ (list
+ :translation (or cons (member nil))
+ :inherits (sequence mutable-sequence mutable-collection
+ generic-sequence collection))
+ (cons
+ :codes (#.sb!vm:list-pointer-type)
+ :translation cons
+ :inherits (list sequence
+ mutable-sequence mutable-collection
+ generic-sequence collection))
+ (null
+ :translation (member nil)
+ :inherits (list sequence
+ mutable-sequence mutable-collection
+ generic-sequence collection symbol)
+ :direct-superclasses (list symbol))
(generic-number :state :read-only)
(number :translation number :inherits (generic-number))
(complex
:inherits (integer rational real number
generic-number)
:codes (#.sb!vm:bignum-type))
-
- (list
- :translation (or cons (member nil))
- :inherits (sequence mutable-sequence mutable-collection
- generic-sequence collection))
- (cons
- :codes (#.sb!vm:list-pointer-type)
- :inherits (list sequence
- mutable-sequence mutable-collection
- generic-sequence collection))
- (null
- :translation (member nil)
- :inherits (list sequence
- mutable-sequence mutable-collection
- generic-sequence collection symbol)
- :direct-superclasses (list symbol))
(stream
:hierarchical-p nil
:state :read-only
;;; See also type-init.lisp where we finish setting up the
;;; translations for built-in types.
(!cold-init-forms
- #-sb-xc-host (/show0 "about to loop over *BUILT-IN-CLASSES*")
(dolist (x *built-in-classes*)
#-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*")
(destructuring-bind
'(t))))
x
(declare (ignore codes state translation))
- (let ((inherits-list (if (eq name 't)
- ()
- (cons 't (reverse inherits))))
+ (let ((inherits-list (if (eq name t)
+ ()
+ (cons t (reverse inherits))))
(class (make-built-in-class
:enumerable enumerable
:name name
:translation (if trans-p :initializing nil)
:direct-superclasses
- (if (eq name 't)
+ (if (eq name t)
nil
(mapcar #'sb!xc:find-class direct-superclasses)))))
(setf (info :type :kind name) :primitive
inherits-vector
depthoid)
:invalidate nil)))))
- #-sb-xc-host (/show0 "done with loop over *BUILT-IN-CLASSES*"))
+ (/show0 "done with loop over *BUILT-IN-CLASSES*"))
;;; Define temporary PCL STANDARD-CLASSes. These will be set up
-;;; correctly and the lisp layout replaced by a PCL wrapper after PCL
+;;; correctly and the Lisp layout replaced by a PCL wrapper after PCL
;;; is loaded and the class defined.
(!cold-init-forms
+ (/show0 "about to define temporary STANDARD-CLASSes")
(dolist (x '((fundamental-stream (t instance stream))))
+ (/show0 "defining temporary STANDARD-CLASS")
(let* ((name (first x))
(inherits-list (second x))
(class (make-standard-class :name name))
(lambda (x)
(class-layout (sb!xc:find-class x)))
inherits-list)))
+ #-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits)
(register-layout (find-and-init-or-check-layout name 0 inherits -1)
- :invalidate nil)))))
+ :invalidate nil))))
+ (/show0 "done defining temporary STANDARD-CLASSes"))
;;; Now that we have set up the class heterarchy, seal the sealed
;;; classes. This must be done after the subclasses have been set up.
projects / sbcl.git / blobdiff