X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=e93efb389c126dd3afb3b9ace5b5fdfc9ad0e0a9;hb=2db3b6b4cb740d5b6512459c223859f747807b09;hp=a3e8f693be372872cf598aa5d468cee24e1272ec;hpb=63cef087068afc157283c0a05ae1f16b962303aa;p=sbcl.git diff --git a/src/code/class.lisp b/src/code/class.lisp index a3e8f69..e93efb3 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -96,7 +96,7 @@ ;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM ;;; in order to guarantee that several hash values can be added without ;;; overflowing into a bignum. -(defconstant layout-clos-hash-max (ash most-positive-fixnum -3) +(def!constant layout-clos-hash-max (ash most-positive-fixnum -3) #!+sb-doc "the inclusive upper bound on LAYOUT-CLOS-HASH values") @@ -233,7 +233,7 @@ ;;;; support for the hash values used by CLOS when working with LAYOUTs -(defconstant layout-clos-hash-length 8) +(def!constant layout-clos-hash-length 8) #!-sb-fluid (declaim (inline layout-clos-hash)) (defun layout-clos-hash (layout i) ;; FIXME: Either this I should be declared to be `(MOD @@ -851,6 +851,21 @@ ;; uncertain, since a subclass of both might be defined nil))) +;;; KLUDGE: we need this because of the need to represent +;;; intersections of two classes, even when empty at a given time, as +;;; uncanonicalized intersections because of the possibility of later +;;; defining a subclass of both classes. The necessity for changing +;;; the default return value from SUBTYPEP to NIL, T if no alternate +;;; method is present comes about because, unlike the other places we +;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the +;;; like, classes are in their own hierarchy with no possibility of +;;; mixtures with other type classes. +(!define-type-method (sb!xc:class :complex-subtypep-arg2) (type1 class2) + (if (and (intersection-type-p type1) + (> (count-if #'class-p (intersection-type-types type1)) 1)) + (values nil nil) + (invoke-complex-subtypep-arg1-method type1 class2 nil t))) + (!define-type-method (sb!xc:class :unparse) (type) (class-proper-name type)) @@ -937,263 +952,181 @@ :inherits (function) :state :read-only) - ;; FIXME: Are COLLECTION and MUTABLE-COLLECTION used for anything - ;; any more? COLLECTION is not defined in ANSI Common Lisp.. - (collection :hierarchical-p nil :state :read-only) - (mutable-collection :state :read-only - :inherits (collection)) - (generic-sequence :state :read-only - :inherits (collection)) - (mutable-sequence :state :read-only - :direct-superclasses (mutable-collection - generic-sequence) - :inherits (mutable-collection - generic-sequence - collection)) - (generic-array :state :read-only - :inherits (mutable-sequence - mutable-collection - generic-sequence - collection)) - (generic-vector :state :read-only - :inherits (generic-array - mutable-sequence mutable-collection - generic-sequence collection)) (array :translation array :codes (#.sb!vm:complex-array-widetag) - :inherits (generic-array mutable-sequence mutable-collection - generic-sequence collection)) + :hierarchical-p nil) (simple-array :translation simple-array :codes (#.sb!vm:simple-array-widetag) - :inherits (array generic-array mutable-sequence mutable-collection - generic-sequence collection)) + :inherits (array)) (sequence - :translation (or cons (member nil) vector) - :inherits (mutable-sequence mutable-collection generic-sequence - collection)) + :translation (or cons (member nil) vector)) (vector :translation vector :codes (#.sb!vm:complex-vector-widetag) - :direct-superclasses (array sequence generic-vector) - :inherits (array sequence generic-vector generic-array - mutable-sequence mutable-collection generic-sequence - collection)) + :direct-superclasses (array sequence) + :inherits (array sequence)) (simple-vector :translation simple-vector :codes (#.sb!vm:simple-vector-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array - sequence generic-vector generic-array - mutable-sequence mutable-collection - generic-sequence collection)) + :inherits (vector simple-array array sequence)) (bit-vector :translation bit-vector :codes (#.sb!vm:complex-bit-vector-widetag) - :inherits (vector array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector array sequence)) (simple-bit-vector :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-widetag) :direct-superclasses (bit-vector simple-array) :inherits (bit-vector vector simple-array - array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + array sequence)) (simple-array-unsigned-byte-2 :translation (simple-array (unsigned-byte 2) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-2-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-unsigned-byte-4 :translation (simple-array (unsigned-byte 4) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-4-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-unsigned-byte-8 :translation (simple-array (unsigned-byte 8) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-8-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-unsigned-byte-16 :translation (simple-array (unsigned-byte 16) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-unsigned-byte-32 :translation (simple-array (unsigned-byte 32) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-signed-byte-8 :translation (simple-array (signed-byte 8) (*)) :codes (#.sb!vm:simple-array-signed-byte-8-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-signed-byte-16 :translation (simple-array (signed-byte 16) (*)) :codes (#.sb!vm:simple-array-signed-byte-16-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-signed-byte-30 :translation (simple-array (signed-byte 30) (*)) :codes (#.sb!vm:simple-array-signed-byte-30-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-signed-byte-32 :translation (simple-array (signed-byte 32) (*)) :codes (#.sb!vm:simple-array-signed-byte-32-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-single-float :translation (simple-array single-float (*)) :codes (#.sb!vm:simple-array-single-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-double-float :translation (simple-array double-float (*)) :codes (#.sb!vm:simple-array-double-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) #!+long-float (simple-array-long-float :translation (simple-array long-float (*)) :codes (#.sb!vm:simple-array-long-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-complex-single-float :translation (simple-array (complex single-float) (*)) :codes (#.sb!vm:simple-array-complex-single-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) (simple-array-complex-double-float :translation (simple-array (complex double-float) (*)) :codes (#.sb!vm:simple-array-complex-double-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + :inherits (vector simple-array array sequence)) #!+long-float (simple-array-complex-long-float :translation (simple-array (complex long-float) (*)) :codes (#.sb!vm:simple-array-complex-long-float-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence - generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) - (generic-string - :state :read-only - :inherits (mutable-sequence mutable-collection generic-sequence - collection)) + :inherits (vector simple-array array sequence)) (string :translation string :codes (#.sb!vm:complex-string-widetag) - :direct-superclasses (vector generic-string) - :inherits (vector array sequence - generic-vector generic-array generic-string - mutable-sequence mutable-collection - generic-sequence collection)) + :direct-superclasses (vector) + :inherits (vector array sequence)) (simple-string :translation simple-string :codes (#.sb!vm:simple-string-widetag) :direct-superclasses (string simple-array) :inherits (string vector simple-array - array sequence - generic-string generic-vector generic-array mutable-sequence - mutable-collection generic-sequence collection)) + array sequence)) (list :translation (or cons (member nil)) - :inherits (sequence mutable-sequence mutable-collection - generic-sequence collection)) + :inherits (sequence)) (cons :codes (#.sb!vm:list-pointer-lowtag) :translation cons - :inherits (list sequence - mutable-sequence mutable-collection - generic-sequence collection)) + :inherits (list sequence)) (null :translation (member nil) - :inherits (symbol list sequence - mutable-sequence mutable-collection - generic-sequence collection) + :inherits (symbol list sequence) :direct-superclasses (symbol list)) - (generic-number :state :read-only) - (number :translation number :inherits (generic-number)) + (number :translation number) (complex :translation complex - :inherits (number generic-number) + :inherits (number) :codes (#.sb!vm:complex-widetag)) (complex-single-float :translation (complex single-float) - :inherits (complex number generic-number) + :inherits (complex number) :codes (#.sb!vm:complex-single-float-widetag)) (complex-double-float :translation (complex double-float) - :inherits (complex number generic-number) + :inherits (complex number) :codes (#.sb!vm:complex-double-float-widetag)) #!+long-float (complex-long-float :translation (complex long-float) - :inherits (complex number generic-number) + :inherits (complex number) :codes (#.sb!vm:complex-long-float-widetag)) - (real :translation real :inherits (number generic-number)) + (real :translation real :inherits (number)) (float :translation float - :inherits (real number generic-number)) + :inherits (real number)) (single-float :translation single-float - :inherits (float real number generic-number) + :inherits (float real number) :codes (#.sb!vm:single-float-widetag)) (double-float :translation double-float - :inherits (float real number generic-number) + :inherits (float real number) :codes (#.sb!vm:double-float-widetag)) #!+long-float (long-float :translation long-float - :inherits (float real number generic-number) + :inherits (float real number) :codes (#.sb!vm:long-float-widetag)) (rational :translation rational - :inherits (real number generic-number)) + :inherits (real number)) (ratio :translation (and rational (not integer)) - :inherits (rational real number generic-number) + :inherits (rational real number) :codes (#.sb!vm:ratio-widetag)) (integer :translation integer - :inherits (rational real number generic-number)) + :inherits (rational real number)) (fixnum - :translation (integer #.sb!vm:*target-most-negative-fixnum* - #.sb!vm:*target-most-positive-fixnum*) - :inherits (integer rational real number - generic-number) + :translation (integer #.sb!xc:most-negative-fixnum + #.sb!xc:most-positive-fixnum) + :inherits (integer rational real number) :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag)) (bignum :translation (and integer (not fixnum)) - :inherits (integer rational real number - generic-number) + :inherits (integer rational real number) :codes (#.sb!vm:bignum-widetag)) (stream :state :read-only @@ -1231,7 +1164,7 @@ (if (eq name t) nil (mapcar #'sb!xc:find-class direct-superclasses))))) - (setf (info :type :kind name) :primitive + (setf (info :type :kind name) #+sb-xc-host :defined #-sb-xc-host :primitive (class-cell-class (find-class-cell name)) class) (unless trans-p (setf (info :type :builtin name) class)) @@ -1285,6 +1218,8 @@ (inherits-list (second x)) (class (make-standard-class :name name)) (class-cell (find-class-cell name))) + ;; Needed to open-code the MAP, below + (declare (type list inherits-list)) (setf (class-cell-class class-cell) class (info :type :class name) class-cell (info :type :kind name) :instance)