;;; 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.
-(def!constant layout-clos-hash-max (ash most-positive-fixnum -3)
+(def!constant layout-clos-hash-max (ash sb!xc:most-positive-fixnum -3)
#!+sb-doc
"the inclusive upper bound on LAYOUT-CLOS-HASH values")
;;; type checking and garbage collection. Whenever a class is
;;; incompatibly redefined, a new layout is allocated. If two object's
;;; layouts are EQ, then they are exactly the same type.
-;;;
-;;; KLUDGE: The genesis code has raw offsets of slots in this
-;;; structure hardwired into it. It would be good to rewrite that code
-;;; so that it looks up those offsets in the compiler's tables, but
-;;; for now if you change this structure, lucky you, you get to grovel
-;;; over the genesis code by hand.:-( -- WHN 19990820
(def!struct (layout
;; KLUDGE: A special hack keeps this from being
;; called when building code for the
;; and PCL has made it invalid and made a note to itself about it
(invalid :uninitialized :type (or cons (member nil t :uninitialized)))
;; the layouts for all classes we inherit. If hierarchical, i.e. if
- ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS,
- ;; so that each inherited layout appears at its expected depth,
- ;; i.e. at its LAYOUT-DEPTHOID value.
+ ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS
+ ;; (least to most specific), so that each inherited layout appears
+ ;; at its expected depth, i.e. at its LAYOUT-DEPTHOID value.
;;
;; Remaining elements are filled by the non-hierarchical layouts or,
;; if they would otherwise be empty, by copies of succeeding layouts.
;; substructure (and hence can be copied into read-only space by
;; PURIFY).
;;
- ;; KLUDGE: This slot is known to the C runtime support code.
- (pure nil :type (member t nil 0)))
+ ;; This slot is known to the C runtime support code.
+ (pure nil :type (member t nil 0))
+ ;; Number of raw words at the end.
+ ;; This slot is known to the C runtime support code.
+ (n-untagged-slots 0 :type index))
(def!method print-object ((layout layout) stream)
(print-unreadable-object (layout stream :type t :identity t)
;;; preexisting class slot value is OK, and if it's not initialized,
;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This
;;; is no longer true, :UNINITIALIZED used instead.
-(declaim (ftype (function (layout classoid index simple-vector layout-depthoid)
+(declaim (ftype (function (layout classoid index simple-vector layout-depthoid
+ index)
layout)
init-or-check-layout))
-(defun init-or-check-layout (layout classoid length inherits depthoid)
+(defun init-or-check-layout
+ (layout classoid length inherits depthoid nuntagged)
(cond ((eq (layout-invalid layout) :uninitialized)
;; There was no layout before, we just created one which
;; we'll now initialize with our information.
(setf (layout-length layout) length
(layout-inherits layout) inherits
(layout-depthoid layout) depthoid
+ (layout-n-untagged-slots layout) nuntagged
(layout-classoid layout) classoid
(layout-invalid layout) nil))
;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this
;; information, and we'll now check that old information
;; which was known with certainty is consistent with current
;; information which is known with certainty.
- (check-layout layout classoid length inherits depthoid)))
+ (check-layout layout classoid length inherits depthoid nuntagged)))
layout)
;;; In code for the target Lisp, we don't use dump LAYOUTs using the
',(layout-classoid layout)
',(layout-length layout)
',(layout-inherits layout)
- ',(layout-depthoid layout)))))
+ ',(layout-depthoid layout)
+ ',(layout-n-untagged-slots layout)))))
;;; If LAYOUT's slot values differ from the specified slot values in
;;; any interesting way, then give a warning and return T.
simple-string
index
simple-vector
- layout-depthoid))
+ layout-depthoid
+ index))
redefine-layout-warning))
(defun redefine-layout-warning (old-context old-layout
- context length inherits depthoid)
+ context length inherits depthoid nuntagged)
(declare (type layout old-layout) (type simple-string old-context context))
(let ((name (layout-proper-name old-layout)))
(or (let ((old-inherits (layout-inherits old-layout)))
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)
(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))
(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))
+ (let ((old-nuntagged (layout-n-untagged-slots old-layout)))
+ (unless (= old-nuntagged nuntagged)
+ (warn "change in instance layout of class ~S:~% ~
+ ~A untagged slots: ~W~% ~
+ ~A untagged slots: ~W"
+ name
+ old-context old-nuntagged
+ context nuntagged)
+ 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))))
;;; Require that LAYOUT data be consistent with CLASS, LENGTH,
;;; INHERITS, and DEPTHOID.
(declaim (ftype (function
- (layout classoid index simple-vector layout-depthoid))
+ (layout classoid index simple-vector layout-depthoid index))
check-layout))
-(defun check-layout (layout classoid length inherits depthoid)
+(defun check-layout (layout classoid length inherits depthoid nuntagged)
(aver (eq (layout-classoid layout) classoid))
(when (redefine-layout-warning "current" layout
- "compile time" length inherits depthoid)
+ "compile time" length inherits depthoid
+ nuntagged)
;; Classic CMU CL had more options here. There are several reasons
;; why they might want more options which are less appropriate for
;; us: (1) It's hard to fit the classic CMU CL flexible approach
;; 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))
;;; Used by the loader to forward-reference layouts for classes whose
;;; definitions may not have been loaded yet. This allows type tests
;;; to be loaded when the type definition hasn't been loaded yet.
-(declaim (ftype (function (symbol index simple-vector layout-depthoid) layout)
+(declaim (ftype (function (symbol index simple-vector layout-depthoid index)
+ layout)
find-and-init-or-check-layout))
-(defun find-and-init-or-check-layout (name length inherits depthoid)
+(defun find-and-init-or-check-layout (name length inherits depthoid nuntagged)
(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)))
+ depthoid
+ nuntagged)))
;;; Record LAYOUT as the layout for its class, adding it as a subtype
;;; of all superclasses. This is the operation that "installs" a
(layout-inherits destruct-layout) (layout-inherits layout)
(layout-depthoid destruct-layout)(layout-depthoid layout)
(layout-length destruct-layout) (layout-length layout)
+ (layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout)
(layout-info destruct-layout) (layout-info layout)
(classoid-layout classoid) destruct-layout)
(setf (layout-invalid layout) nil
(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 (or null classoid) new-value))
(cond
(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))
\f
(setq
*built-in-classes*
'((t :state :read-only :translation t)
- (character :enumerable t :translation base-char
- :prototype-form (code-char 42))
- (base-char :enumerable t
- :inherits (character)
- :codes (#.sb!vm:base-char-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)
:translation (and integer (not fixnum))
:inherits (integer rational real number)
:codes (#.sb!vm:bignum-widetag)
- ;; FIXME: wrong for 64-bit!
- :prototype-form (expt 2 42))
+ :prototype-form (expt 2 #.(* sb!vm:n-word-bits (/ 3 2))))
(array :translation array :codes (#.sb!vm:complex-array-widetag)
:hierarchical-p nil
:direct-superclasses (vector simple-array)
: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)
: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)
: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)
: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)
: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)
: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)
: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))
:inherits (symbol list sequence)
:direct-superclasses (symbol list)
:prototype-form 'nil)
-
(stream
:state :read-only
:depth 3
- :inherits (instance)
- :prototype-form (make-broadcast-stream)))))
+ :inherits (instance))
+ (file-stream
+ :state :read-only
+ :depth 5
+ :inherits (stream))
+ (string-stream
+ :state :read-only
+ :depth 5
+ :inherits (stream)))))
;;; See also src/code/class-init.lisp where we finish setting up the
;;; translations for built-in types.
(find-and-init-or-check-layout name
0
inherits-vector
- depthoid)
+ depthoid
+ 0)
:invalidate nil)))))
(/show0 "done with loop over *BUILT-IN-CLASSES*"))
(classoid-layout (find-classoid 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)
+ (register-layout (find-and-init-or-check-layout name 0 inherits -1 0)
:invalidate nil))))
(/show0 "done defining temporary STANDARD-CLASSes"))
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*
projects / sbcl.git / blobdiff