X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=535914c6cadb9688c04216667c1b90b6a8e32e17;hb=77d1a39f28fe8d240cf441a9a54a80d4bc98ea52;hp=0d19c7caddf3a2b15bdcd3e798c31ed1edc7f0b0;hpb=22b819c0cd0ca0ea5be52ba280b9e9e0b8e86210;p=sbcl.git diff --git a/src/code/class.lisp b/src/code/class.lisp index 0d19c7c..535914c 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -358,8 +358,8 @@ inherits :key #'layout-proper-name) (warn "change in superclasses of class ~S:~% ~ - ~A superclasses: ~S~% ~ - ~A superclasses: ~S" + ~A superclasses: ~S~% ~ + ~A superclasses: ~S" name old-context (map 'list #'layout-proper-name old-inherits) @@ -370,8 +370,8 @@ (when diff (warn "in class ~S:~% ~ - ~:(~A~) definition of superclass ~S is incompatible with~% ~ - ~A definition." + ~:(~A~) definition of superclass ~S is incompatible with~% ~ + ~A definition." name old-context (layout-proper-name (svref old-inherits diff)) @@ -380,15 +380,15 @@ (let ((old-length (layout-length old-layout))) (unless (= old-length length) (warn "change in instance length of class ~S:~% ~ - ~A length: ~W~% ~ - ~A length: ~W" + ~A length: ~W~% ~ + ~A length: ~W" name old-context old-length context length) t)) (unless (= (layout-depthoid old-layout) depthoid) (warn "change in the inheritance structure of class ~S~% ~ - between the ~A definition and the ~A definition" + between the ~A definition and the ~A definition" name old-context context) t)))) @@ -415,7 +415,7 @@ ;; system from scratch, so we no longer need this functionality in ;; order to maintain the SBCL system by modifying running images. (error "The class ~S was not changed, and there's no guarantee that~@ - the loaded code (which expected another layout) will work." + the loaded code (which expected another layout) will work." (layout-proper-name layout))) (values)) @@ -431,7 +431,7 @@ (let ((layout (find-layout name))) (init-or-check-layout layout (or (find-classoid name nil) - (make-undefined-classoid name)) + (layout-classoid layout)) length inherits depthoid))) @@ -485,19 +485,18 @@ (setf (layout-invalid layout) nil (classoid-layout classoid) layout)) - (let ((inherits (layout-inherits layout))) - (dotimes (i (length inherits)) ; FIXME: should be DOVECTOR - (let* ((super (layout-classoid (svref inherits i))) - (subclasses (or (classoid-subclasses super) - (setf (classoid-subclasses super) - (make-hash-table :test 'eq))))) - (when (and (eq (classoid-state super) :sealed) - (not (gethash classoid subclasses))) - (warn "unsealing sealed class ~S in order to subclass it" - (classoid-name super)) - (setf (classoid-state super) :read-only)) - (setf (gethash classoid subclasses) - (or destruct-layout layout)))))) + (dovector (super-layout (layout-inherits layout)) + (let* ((super (layout-classoid super-layout)) + (subclasses (or (classoid-subclasses super) + (setf (classoid-subclasses super) + (make-hash-table :test 'eq))))) + (when (and (eq (classoid-state super) :sealed) + (not (gethash classoid subclasses))) + (warn "unsealing sealed class ~S in order to subclass it" + (classoid-name super)) + (setf (classoid-state super) :read-only)) + (setf (gethash classoid subclasses) + (or destruct-layout layout))))) (values)) ); EVAL-WHEN @@ -700,65 +699,79 @@ (setf (info :type :classoid name) (make-classoid-cell name)))) -;;; FIXME: When the system is stable, this DECLAIM FTYPE should -;;; probably go away in favor of the DEFKNOWN for FIND-CLASS. -(declaim (ftype (function (symbol &optional t (or null sb!c::lexenv))) - find-classoid)) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun find-classoid (name &optional (errorp t) environment) #!+sb-doc - "Return the class with the specified NAME. If ERRORP is false, then NIL is - returned when no such class exists." + "Return the class with the specified NAME. If ERRORP is false, then +NIL is returned when no such class exists." (declare (type symbol name) (ignore environment)) (let ((res (classoid-cell-classoid (find-classoid-cell name)))) (if (or res (not errorp)) res - (error "class not yet defined:~% ~S" name)))) + (error 'simple-type-error + :datum nil + :expected-type 'class + :format-control "class not yet defined:~% ~S" + :format-arguments (list name))))) (defun (setf find-classoid) (new-value name) - #-sb-xc (declare (type classoid new-value)) - (ecase (info :type :kind name) - ((nil)) - (:forthcoming-defclass-type - ;; XXX Currently, nothing needs to be done in this case. Later, when - ;; PCL is integrated tighter into SBCL, this might need more work. - nil) - (:instance - ;; KLUDGE: The reason these clauses aren't directly parallel is - ;; that we need to use the internal CLASSOID structure ourselves, - ;; because we don't have CLASSes to work with until PCL is built. - ;; In the host, CLASSes have an approximately one-to-one - ;; correspondence with the target CLASSOIDs (as well as with the - ;; target CLASSes, modulo potential differences with respect to - ;; conditions). - #+sb-xc-host - (let ((old (class-of (find-classoid name))) - (new (class-of new-value))) - (unless (eq old new) - (bug "trying to change the metaclass of ~S from ~S to ~S in the ~ - cross-compiler." - name (class-name old) (class-name new)))) - #-sb-xc-host - (let ((old (classoid-of (find-classoid name))) - (new (classoid-of new-value))) - (unless (eq old new) - (warn "changing meta-class of ~S from ~S to ~S" - name (classoid-name old) (classoid-name new))))) - (:primitive - (error "illegal to redefine standard type ~S" name)) - (:defined - (warn "redefining DEFTYPE type to be a class: ~S" name) - (setf (info :type :expander name) nil))) + #-sb-xc (declare (type (or null classoid) new-value)) + (cond + ((null new-value) + (ecase (info :type :kind name) + ((nil)) + (:defined) + (:primitive + (error "attempt to redefine :PRIMITIVE type: ~S" name)) + ((:forthcoming-defclass-type :instance) + (setf (info :type :kind name) nil + (info :type :classoid name) nil + (info :type :documentation name) nil + (info :type :compiler-layout name) nil)))) + (t + (ecase (info :type :kind name) + ((nil)) + (:forthcoming-defclass-type + ;; XXX Currently, nothing needs to be done in this + ;; case. Later, when PCL is integrated tighter into SBCL, this + ;; might need more work. + nil) + (:instance + ;; KLUDGE: The reason these clauses aren't directly parallel + ;; is that we need to use the internal CLASSOID structure + ;; ourselves, because we don't have CLASSes to work with until + ;; PCL is built. In the host, CLASSes have an approximately + ;; one-to-one correspondence with the target CLASSOIDs (as + ;; well as with the target CLASSes, modulo potential + ;; differences with respect to conditions). + #+sb-xc-host + (let ((old (class-of (find-classoid name))) + (new (class-of new-value))) + (unless (eq old new) + (bug "trying to change the metaclass of ~S from ~S to ~S in the ~ + cross-compiler." + name (class-name old) (class-name new)))) + #-sb-xc-host + (let ((old (classoid-of (find-classoid name))) + (new (classoid-of new-value))) + (unless (eq old new) + (warn "changing meta-class of ~S from ~S to ~S" + name (classoid-name old) (classoid-name new))))) + (:primitive + (error "illegal to redefine standard type ~S" name)) + (:defined + (warn "redefining DEFTYPE type to be a class: ~S" name) + (setf (info :type :expander name) nil))) - (remhash name *forward-referenced-layouts*) - (%note-type-defined name) - (setf (info :type :kind name) :instance) - (setf (classoid-cell-classoid (find-classoid-cell name)) new-value) - (unless (eq (info :type :compiler-layout name) - (classoid-layout new-value)) - (setf (info :type :compiler-layout name) (classoid-layout new-value))) + (remhash name *forward-referenced-layouts*) + (%note-type-defined name) + (setf (info :type :kind name) :instance) + (setf (classoid-cell-classoid (find-classoid-cell name)) new-value) + (unless (eq (info :type :compiler-layout name) + (classoid-layout new-value)) + (setf (info :type :compiler-layout name) (classoid-layout new-value))))) new-value) ) ; EVAL-WHEN - + ;;; Called when we are about to define NAME as a class meeting some ;;; predicate (such as a meta-class type test.) The first result is ;;; always of the desired class. The second result is any existing @@ -862,6 +875,9 @@ (values nil nil) (invoke-complex-subtypep-arg1-method type1 class2 nil t))) +(!define-type-method (classoid :negate) (type) + (make-negation-type :type type)) + (!define-type-method (classoid :unparse) (type) (classoid-proper-name type)) @@ -919,34 +935,106 @@ (setq *built-in-classes* '((t :state :read-only :translation t) - (character :enumerable t :translation base-char) - (base-char :enumerable t - :inherits (character) - :codes (#.sb!vm:base-char-widetag)) - (symbol :codes (#.sb!vm:symbol-header-widetag)) + (character :enumerable t + :codes (#.sb!vm:character-widetag) + :translation (character-set) + :prototype-form (code-char 42)) + (symbol :codes (#.sb!vm:symbol-header-widetag) + :prototype-form '#:mu) (instance :state :read-only) - (system-area-pointer :codes (#.sb!vm:sap-widetag)) - (weak-pointer :codes (#.sb!vm:weak-pointer-widetag)) + (system-area-pointer :codes (#.sb!vm:sap-widetag) + :prototype-form (sb!sys:int-sap 42)) + (weak-pointer :codes (#.sb!vm:weak-pointer-widetag) + :prototype-form (sb!ext:make-weak-pointer (find-package "CL"))) (code-component :codes (#.sb!vm:code-header-widetag)) (lra :codes (#.sb!vm:return-pc-header-widetag)) - (fdefn :codes (#.sb!vm:fdefn-widetag)) + (fdefn :codes (#.sb!vm:fdefn-widetag) + :prototype-form (sb!kernel:make-fdefn "42")) (random-class) ; used for unknown type codes (function :codes (#.sb!vm:closure-header-widetag #.sb!vm:simple-fun-header-widetag) - :state :read-only) + :state :read-only + :prototype-form (function (lambda () 42))) (funcallable-instance :inherits (function) :state :read-only) + (number :translation number) + (complex + :translation complex + :inherits (number) + :codes (#.sb!vm:complex-widetag) + :prototype-form (complex 42 42)) + (complex-single-float + :translation (complex single-float) + :inherits (complex number) + :codes (#.sb!vm:complex-single-float-widetag) + :prototype-form (complex 42f0 42f0)) + (complex-double-float + :translation (complex double-float) + :inherits (complex number) + :codes (#.sb!vm:complex-double-float-widetag) + :prototype-form (complex 42d0 42d0)) + #!+long-float + (complex-long-float + :translation (complex long-float) + :inherits (complex number) + :codes (#.sb!vm:complex-long-float-widetag) + :prototype-form (complex 42l0 42l0)) + (real :translation real :inherits (number)) + (float + :translation float + :inherits (real number)) + (single-float + :translation single-float + :inherits (float real number) + :codes (#.sb!vm:single-float-widetag) + :prototype-form 42f0) + (double-float + :translation double-float + :inherits (float real number) + :codes (#.sb!vm:double-float-widetag) + :prototype-form 42d0) + #!+long-float + (long-float + :translation long-float + :inherits (float real number) + :codes (#.sb!vm:long-float-widetag) + :prototype-form 42l0) + (rational + :translation rational + :inherits (real number)) + (ratio + :translation (and rational (not integer)) + :inherits (rational real number) + :codes (#.sb!vm:ratio-widetag) + :prototype-form 1/42) + (integer + :translation integer + :inherits (rational real number)) + (fixnum + :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) + :prototype-form 42) + (bignum + :translation (and integer (not fixnum)) + :inherits (integer rational real number) + :codes (#.sb!vm:bignum-widetag) + :prototype-form (expt 2 #.(* sb!vm:n-word-bits (/ 3 2)))) + (array :translation array :codes (#.sb!vm:complex-array-widetag) - :hierarchical-p nil) + :hierarchical-p nil + :prototype-form (make-array nil :adjustable t)) (simple-array :translation simple-array :codes (#.sb!vm:simple-array-widetag) - :inherits (array)) + :inherits (array) + :prototype-form (make-array nil)) (sequence :translation (or cons (member nil) vector)) (vector @@ -956,176 +1044,248 @@ (simple-vector :translation simple-vector :codes (#.sb!vm:simple-vector-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0)) (bit-vector :translation bit-vector :codes (#.sb!vm:complex-bit-vector-widetag) - :inherits (vector array sequence)) + :inherits (vector array sequence) + :prototype-form (make-array 0 :element-type 'bit :fill-pointer t)) (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)) + array sequence) + :prototype-form (make-array 0 :element-type 'bit)) (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)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 2))) (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)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 4))) + (simple-array-unsigned-byte-7 + :translation (simple-array (unsigned-byte 7) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-7-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 7))) (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)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 8))) + (simple-array-unsigned-byte-15 + :translation (simple-array (unsigned-byte 15) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-15-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 15))) (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)) + :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) + :prototype-form (make-array 0 :element-type '(unsigned-byte 16))) + #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-unsigned-byte-29 + :translation (simple-array (unsigned-byte 29) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-29-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 29))) + (simple-array-unsigned-byte-31 + :translation (simple-array (unsigned-byte 31) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-31-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 31))) (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)) + :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) + :prototype-form (make-array 0 :element-type '(unsigned-byte 32))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-unsigned-byte-60 + :translation (simple-array (unsigned-byte 60) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-60-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 60))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-unsigned-byte-63 + :translation (simple-array (unsigned-byte 63) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-63-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 63))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-unsigned-byte-64 + :translation (simple-array (unsigned-byte 64) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-64-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 64))) (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)) + :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) + :prototype-form (make-array 0 :element-type '(signed-byte 8))) (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)) + :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) + :prototype-form (make-array 0 :element-type '(signed-byte 16))) + #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) (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)) + :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) + :prototype-form (make-array 0 :element-type '(signed-byte 30))) (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)) + :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) + :prototype-form (make-array 0 :element-type '(signed-byte 32))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-signed-byte-61 + :translation (simple-array (signed-byte 61) (*)) + :codes (#.sb!vm:simple-array-signed-byte-61-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(signed-byte 61))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-signed-byte-64 + :translation (simple-array (signed-byte 64) (*)) + :codes (#.sb!vm:simple-array-signed-byte-64-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(signed-byte 64))) (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)) + :translation (simple-array single-float (*)) + :codes (#.sb!vm:simple-array-single-float-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type 'single-float)) (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)) - #!+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)) - (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)) - (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)) - #!+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)) - (string - :translation string - :codes (#.sb!vm:complex-string-widetag) - :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)) - (list - :translation (or cons (member nil)) - :inherits (sequence)) - (cons - :codes (#.sb!vm:list-pointer-lowtag) - :translation cons - :inherits (list sequence)) - (null - :translation (member nil) - :inherits (symbol list sequence) - :direct-superclasses (symbol list)) - (number :translation number) - (complex - :translation complex - :inherits (number) - :codes (#.sb!vm:complex-widetag)) - (complex-single-float - :translation (complex single-float) - :inherits (complex number) - :codes (#.sb!vm:complex-single-float-widetag)) - (complex-double-float - :translation (complex double-float) - :inherits (complex number) - :codes (#.sb!vm:complex-double-float-widetag)) - #!+long-float - (complex-long-float - :translation (complex long-float) - :inherits (complex number) - :codes (#.sb!vm:complex-long-float-widetag)) - (real :translation real :inherits (number)) - (float - :translation float - :inherits (real number)) - (single-float - :translation single-float - :inherits (float real number) - :codes (#.sb!vm:single-float-widetag)) - (double-float - :translation double-float - :inherits (float real number) - :codes (#.sb!vm:double-float-widetag)) - #!+long-float - (long-float - :translation long-float - :inherits (float real number) - :codes (#.sb!vm:long-float-widetag)) - (rational - :translation rational - :inherits (real number)) - (ratio - :translation (and rational (not integer)) - :inherits (rational real number) - :codes (#.sb!vm:ratio-widetag)) - (integer - :translation integer - :inherits (rational real number)) - (fixnum - :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) - :codes (#.sb!vm:bignum-widetag)) - (stream - :state :read-only - :depth 3 - :inherits (instance))))) + :translation (simple-array double-float (*)) + :codes (#.sb!vm:simple-array-double-float-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type 'double-float)) + #!+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) + :prototype-form (make-array 0 :element-type 'long-float)) + (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) + :prototype-form (make-array 0 :element-type '(complex single-float))) + (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) + :prototype-form (make-array 0 :element-type '(complex double-float))) + #!+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) + :prototype-form (make-array 0 :element-type '(complex long-float))) + (string + :translation string + :direct-superclasses (vector) + :inherits (vector array sequence)) + (simple-string + :translation simple-string + :direct-superclasses (string simple-array) + :inherits (string vector simple-array array sequence)) + (vector-nil + :translation (vector nil) + :codes (#.sb!vm:complex-vector-nil-widetag) + :direct-superclasses (string) + :inherits (string vector array sequence) + :prototype-form (make-array 0 :element-type 'nil :fill-pointer t)) + (simple-array-nil + :translation (simple-array nil (*)) + :codes (#.sb!vm:simple-array-nil-widetag) + :direct-superclasses (vector-nil simple-string) + :inherits (vector-nil simple-string string vector simple-array + array sequence) + :prototype-form (make-array 0 :element-type 'nil)) + (base-string + :translation base-string + :codes (#.sb!vm:complex-base-string-widetag) + :direct-superclasses (string) + :inherits (string vector array sequence) + :prototype-form (make-array 0 :element-type 'base-char :fill-pointer t)) + (simple-base-string + :translation simple-base-string + :codes (#.sb!vm:simple-base-string-widetag) + :direct-superclasses (base-string simple-string) + :inherits (base-string simple-string string vector simple-array + array sequence) + :prototype-form (make-array 0 :element-type 'base-char)) + #!+sb-unicode + (character-string + :translation (vector character) + :codes (#.sb!vm:complex-character-string-widetag) + :direct-superclasses (string) + :inherits (string vector array sequence) + :prototype-form (make-array 0 :element-type 'character :fill-pointer t)) + #!+sb-unicode + (simple-character-string + :translation (simple-array character (*)) + :codes (#.sb!vm:simple-character-string-widetag) + :direct-superclasses (character-string simple-string) + :inherits (character-string simple-string string vector simple-array + array sequence) + :prototype-form (make-array 0 :element-type 'character)) + (list + :translation (or cons (member nil)) + :inherits (sequence)) + (cons + :codes (#.sb!vm:list-pointer-lowtag) + :translation cons + :inherits (list sequence) + :prototype-form (cons nil nil)) + (null + :translation (member nil) + :inherits (symbol list sequence) + :direct-superclasses (symbol list) + :prototype-form 'nil) + (stream + :state :read-only + :depth 3 + :inherits (instance)) + (file-stream + :state :read-only + :depth 5 + :inherits (stream)) + (string-stream + :state :read-only + :depth 5 + :inherits (stream))))) -;;; comment from CMU CL: -;;; See also type-init.lisp where we finish setting up the -;;; translations for built-in types. +;;; See also src/code/class-init.lisp where we finish setting up the +;;; translations for built-in types. (!cold-init-forms (dolist (x *built-in-classes*) #-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*") @@ -1137,12 +1297,13 @@ enumerable state depth + prototype-form (hierarchical-p t) ; might be modified below (direct-superclasses (if inherits (list (car inherits)) '(t)))) x - (declare (ignore codes state translation)) + (declare (ignore codes state translation prototype-form)) (let ((inherits-list (if (eq name t) () (cons t (reverse inherits)))) @@ -1252,9 +1413,8 @@ (let ((inherits (layout-inherits layout)) (classoid (layout-classoid layout))) (modify-classoid classoid) - (dotimes (i (length inherits)) ; FIXME: DOVECTOR - (let* ((super (svref inherits i)) - (subs (classoid-subclasses (layout-classoid super)))) + (dovector (super inherits) + (let ((subs (classoid-subclasses (layout-classoid super)))) (when subs (remhash classoid subs))))) (values)) @@ -1279,11 +1439,6 @@ name layout)))))) -;;; a vector that maps type codes to layouts, used for quickly finding -;;; the layouts of built-in classes -(defvar *built-in-class-codes*) ; initialized in cold load -(declaim (type simple-vector *built-in-class-codes*)) - (!cold-init-forms #-sb-xc-host (/show0 "about to set *BUILT-IN-CLASS-CODES*") (setq *built-in-class-codes*