mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Add DEF-TYPE-MODEL macro for defining ctype subtypes
The macro will soon be enhanced to automatically define a caching constructor so that all ctype instances get hash-consed. Additionally: * Require that all DEFINE-TYPE-CLASS forms precede type methods and any constructor call for ctype instances in that type class. * Delete MEMOIZED-TYPE-CLASS-NAME->ID. It's as simple as looking at a table, since it is now forbidden ask for the ID of a not-yet-defined type-class. * Delete compiler macro on TYPE-CLASS-OR-LOSE. It does not remain in the image post-build, and it doesn't help the build any.
This commit is contained in:
Douglas Katzman
parent
023cdc444f
commit
e3013177ae
|
|
@ -795,6 +795,21 @@ between the ~A definition and the ~A definition"
|
|||
(define-type-class classoid :enumerable #'classoid-enumerable-p
|
||||
:might-contain-other-types nil)
|
||||
|
||||
(defmacro classoid-bits (x)
|
||||
;; HASH-LAYOUT-NAME picks a random number if NAME is NULL
|
||||
`(logior (logand (hash-layout-name ,x) +type-hash-mask+)
|
||||
,(ctype-class-bits 'classoid)))
|
||||
;;; Now that the type-class has an ID, the various constructors can be defined.
|
||||
(macrolet ((def-make (name args &aux (allocator (symbolicate "!ALLOC-" name)))
|
||||
`(defun ,(symbolicate "MAKE-" name) ,args
|
||||
(declare (inline ,allocator))
|
||||
(,allocator (classoid-bits name) ,@(remove '&key args)))))
|
||||
(def-make undefined-classoid (name))
|
||||
(def-make condition-classoid (&key name))
|
||||
(def-make structure-classoid (&key name))
|
||||
(def-make standard-classoid (&key name pcl-class))
|
||||
(def-make static-classoid (&key name)))
|
||||
|
||||
(defun classoid-inherits-from (sub super-or-name)
|
||||
(declare (type classoid sub)
|
||||
(type (or symbol classoid) super-or-name))
|
||||
|
|
@ -1360,7 +1375,7 @@ between the ~A definition and the ~A definition"
|
|||
(setf (classoid-cell-classoid
|
||||
(find-classoid-cell name :create t))
|
||||
(!make-built-in-classoid
|
||||
:%bits (pack-ctype-bits classoid name)
|
||||
:%bits (classoid-bits name)
|
||||
:name name
|
||||
:translation #+sb-xc-host (if trans-p :initializing nil)
|
||||
#-sb-xc-host translation
|
||||
|
|
|
|||
|
|
@ -519,9 +519,8 @@
|
|||
;;; referenced layouts. Users should never see them.
|
||||
(def!struct (undefined-classoid
|
||||
(:include classoid)
|
||||
(:copier nil)
|
||||
(:constructor make-undefined-classoid
|
||||
(name &aux (%bits (pack-ctype-bits classoid name))))))
|
||||
(:constructor !alloc-undefined-classoid (%bits name))
|
||||
(:copier nil)))
|
||||
|
||||
;;; BUILT-IN-CLASS is used to represent the standard classes that
|
||||
;;; aren't defined with DEFSTRUCT and other specially implemented
|
||||
|
|
@ -542,9 +541,8 @@
|
|||
(predicate (missing-arg) :type (sfunction (t) boolean) :read-only t))
|
||||
|
||||
(def!struct (condition-classoid (:include classoid)
|
||||
(:copier nil)
|
||||
(:constructor make-condition-classoid
|
||||
(&key name &aux (%bits (pack-ctype-bits classoid name)))))
|
||||
(:constructor !alloc-condition-classoid (%bits name))
|
||||
(:copier nil))
|
||||
;; list of CONDITION-SLOT structures for the direct slots of this
|
||||
;; class
|
||||
(slots nil :type list)
|
||||
|
|
@ -574,9 +572,8 @@
|
|||
;;; don't have a corresponding class.
|
||||
(def!struct (structure-classoid
|
||||
(:include classoid)
|
||||
(:copier nil)
|
||||
(:constructor make-structure-classoid
|
||||
(&key name &aux (%bits (pack-ctype-bits classoid name))))))
|
||||
(:constructor !alloc-structure-classoid (%bits name))
|
||||
(:copier nil)))
|
||||
|
||||
;;;; classoid namespace
|
||||
|
||||
|
|
@ -606,18 +603,16 @@
|
|||
;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. The type system
|
||||
;;; side does not need to distinguish between STANDARD-CLASS and
|
||||
;;; FUNCALLABLE-STANDARD-CLASS.
|
||||
(def!struct (standard-classoid (:include classoid)
|
||||
(:copier nil)
|
||||
(:constructor make-standard-classoid
|
||||
(&key name pcl-class
|
||||
&aux (%bits (pack-ctype-bits classoid name)))))
|
||||
(def!struct (standard-classoid
|
||||
(:include classoid)
|
||||
(:constructor !alloc-standard-classoid (%bits name pcl-class))
|
||||
(:copier nil))
|
||||
old-layouts)
|
||||
;;; a metaclass for classes which aren't standardlike but will never
|
||||
;;; change either.
|
||||
(def!struct (static-classoid (:include classoid)
|
||||
(:copier nil)
|
||||
(:constructor make-static-classoid
|
||||
(&key name &aux (%bits (pack-ctype-bits classoid name))))))
|
||||
(:constructor !alloc-static-classoid (%bits name))
|
||||
(:copier nil)))
|
||||
|
||||
(declaim (freeze-type built-in-classoid condition-classoid
|
||||
standard-classoid static-classoid))
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@
|
|||
(defvar *ctype-hash-state* (make-random-state))
|
||||
;; There are 5 bits in a type-class index, so at most 32 type-classes
|
||||
;; of which about 17 are currently defined.
|
||||
(defvar *type-classes* (make-array 32 :fill-pointer 0))
|
||||
(defvar *type-classes* (make-array 32 :initial-element nil))
|
||||
;; We track for each type-class whether it has any descendant class.
|
||||
;; Inheritance is implemented by copying the vtable from an ancestor
|
||||
;; to the descendant at the time the descendant is defined.
|
||||
|
|
@ -59,27 +59,6 @@
|
|||
;; can detect whether function definitions have occurred.
|
||||
(def *type-cache-nonce* 0))
|
||||
|
||||
#-sb-xc-host
|
||||
(define-compiler-macro type-class-or-lose (&whole form name)
|
||||
;; If NAME is a quoted constant, the resultant form should be
|
||||
;; a fixed index into *TYPE-CLASSES* except that during the building
|
||||
;; of the cross-compiler the array hasn't been populated yet.
|
||||
;; One solution to that, which I favored, is that DEFINE-TYPE-CLASS
|
||||
;; appear before the structure definition that uses the corresponding
|
||||
;; type-class in its slot initializer. That posed a problem for
|
||||
;; the :INHERITS option, because the constructor of a descendant
|
||||
;; grabs all the methods [sic] from its ancestor at the time the
|
||||
;; descendant is defined, which means the methods of the ancestor
|
||||
;; should have been filled in, which means at least one DEFINE-TYPE-CLASS
|
||||
;; wants to appear _after_ a structure definition that uses it.
|
||||
(declare (notinline position)) ; out-of-order use of #'type-class-name
|
||||
(if (constantp name)
|
||||
(let ((name (constant-form-value name)))
|
||||
`(aref *type-classes*
|
||||
,(or (position name *type-classes* :key #'type-class-name)
|
||||
(error "~S is not a defined type class." name))))
|
||||
form))
|
||||
|
||||
(defun must-supply-this (&rest foo)
|
||||
(/show0 "failing in MUST-SUPPLY-THIS")
|
||||
(error "missing type method for ~S" foo))
|
||||
|
|
@ -202,31 +181,12 @@
|
|||
)
|
||||
(declaim (freeze-type type-class))
|
||||
|
||||
(defun type-class-or-lose (name)
|
||||
(or (find name *type-classes* :key #'type-class-name)
|
||||
(defun !type-class-or-lose (name)
|
||||
;; Careful about NIL elements since they aren't populated strictly in order
|
||||
(or (find-if (lambda (x) (and x (eq (type-class-name x) name)))
|
||||
*type-classes*)
|
||||
(error "~S is not a defined type class." name)))
|
||||
|
||||
(defun type-class-name->id (name)
|
||||
(or (position name *type-classes* :key #'type-class-name)
|
||||
(error "~S is not a defined type class." name)))
|
||||
|
||||
;;; DEFINE-TYPE-METHOD, DEFINE-TYPE-CLASS, and DEFSTRUCT forms for each
|
||||
;;; type class can appear in a random order. To allow this, we have to delay
|
||||
;;; lookup of the index into *TYPE-CLASSES*. It would be inefficient to scan
|
||||
;;; *TYPE-CLASSES* on every call of a constructor of an instance though,
|
||||
;;; so we cache the index in a cons cell.
|
||||
;;; make-host-2 has an easier time at this - it just looks at the vector
|
||||
;;; of *TYPE-CLASSES* built up in make-host-1. No caching necessary.
|
||||
(defmacro memoized-type-class-name->id (class-name)
|
||||
#+sb-xc-host
|
||||
`(let* ((cell (load-time-value (list ',class-name)))
|
||||
(value (car cell)))
|
||||
(if (integerp value)
|
||||
value
|
||||
(setf (car cell) (type-class-name->id ',class-name))))
|
||||
#-sb-xc-host
|
||||
(position class-name *type-classes* :key #'type-class-name))
|
||||
|
||||
(defun ctype-random ()
|
||||
#+sb-xc-host
|
||||
(setq *ctype-lcg-state*
|
||||
|
|
@ -276,12 +236,50 @@
|
|||
;;; if applicable. For types which are not array specializations,
|
||||
;;; the bits are arbitrary.
|
||||
(defmacro type-saetp-index (ctype) `(ldb (byte 5 22) (type-%bits ,ctype)))
|
||||
|
||||
(defconstant +type-internedp+ (ash 1 20))
|
||||
(defconstant +type-admits-type=-optimization+ (ash 1 21))
|
||||
(defmacro type-bits-internedp (bits) `(logbitp 20 ,bits))
|
||||
(defmacro type-bits-admit-type=-optimization (bits) `(logbitp 21 ,bits))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defconstant +type-internedp+ (ash 1 20))
|
||||
(defconstant +type-admits-type=-optimization+ (ash 1 21))
|
||||
(defun ctype-class-bits (type-class)
|
||||
(logior (ash (type-class-name->id type-class) 27)
|
||||
;; NUMBER, MEMBER, and CLASSOID admit TYPE= optimization.
|
||||
;; Other type classes might, but this is the conservative assumption.
|
||||
(if (member type-class '(number member classoid))
|
||||
+type-admits-type=-optimization+ 0)
|
||||
;; The mapping from name to a CLASSOID type is unique,
|
||||
;; therefore all CLASSOIDs have the "interned" bit on.
|
||||
(if (eq type-class 'classoid) +type-internedp+ 0)))
|
||||
(defparameter *def-type-model-forms* nil)
|
||||
(defvar *type-class-list*
|
||||
;; type-class and ctype instance types in that class
|
||||
'((named named-type)
|
||||
(classoid classoid)
|
||||
(values values-type)
|
||||
(function fun-type fun-designator-type)
|
||||
(constant constant-type)
|
||||
(hairy hairy-type unknown-type)
|
||||
(intersection intersection-type)
|
||||
(union union-type)
|
||||
(negation negation-type)
|
||||
(number numeric-type)
|
||||
(array array-type)
|
||||
(character-set character-set-type)
|
||||
(member member-type)
|
||||
(cons cons-type)
|
||||
(simd-pack simd-pack-type)
|
||||
(simd-pack-256 simd-pack-256-type)
|
||||
;; clearly alien-type-type is not consistent with the (FOO FOO-TYPE) theme
|
||||
(alien alien-type-type)))
|
||||
(defun ctype-instance-type->type-class (name)
|
||||
(car (the (not null)
|
||||
(find name *type-class-list* :key #'cdr :test #'member))))
|
||||
(defun type-class-name->id (name)
|
||||
(or #+sb-xc-host (position name *type-class-list* :key #'car)
|
||||
#-sb-xc-host (position name *type-classes* :key #'type-class-name)
|
||||
(error "~S is not a defined type class." name))))
|
||||
|
||||
;;; For system build-time only
|
||||
(defun pack-interned-ctype-bits (type-class &optional hash saetp-index)
|
||||
(let ((hash (or hash (ctype-random))))
|
||||
|
|
@ -293,28 +291,6 @@
|
|||
(if (eq type-class 'array) 0 +type-admits-type=-optimization+)
|
||||
+type-internedp+)))
|
||||
|
||||
;;; For runtime
|
||||
;;; CLASSOIDs have a deterministic hash based on the name,
|
||||
;;; utilizing the same hash calculation as with LAYOUT instances.
|
||||
;;; NUMBER types could compute a stable hash too (but they don't currently)
|
||||
;;; which would mean that HASH-not-equal implies TYPE-not-equal.
|
||||
;;; Most other things would not benefit.
|
||||
(defmacro pack-ctype-bits (type-class &optional name)
|
||||
;;; TYPE-CLASS is an unevaluated argument
|
||||
(when (eq type-class 'classoid)
|
||||
(aver name))
|
||||
(let ((hash (if name `(hash-layout-name ,name) '(ctype-random))))
|
||||
`(logior (ash (memoized-type-class-name->id ,type-class) 27)
|
||||
(logand ,hash +type-hash-mask+)
|
||||
;; NUMBER, MEMBER, and CLASSOID admit TYPE= optimization.
|
||||
;; Other type classes might, but this is the conservative assumption.
|
||||
,@(when (member type-class '(number member classoid))
|
||||
'(+type-admits-type=-optimization+))
|
||||
;; The mapping from name to a CLASSOID type is unique,
|
||||
;; therefore all CLASSOIDs have the "interned" bit on.
|
||||
,@(when (eq type-class 'classoid)
|
||||
'(+type-internedp+)))))
|
||||
|
||||
(declaim (inline type-might-contain-other-types-p))
|
||||
(defun type-might-contain-other-types-p (ctype)
|
||||
(type-class-might-contain-other-types-p (type-class ctype)))
|
||||
|
|
@ -394,7 +370,7 @@
|
|||
(!cold-init-forms
|
||||
,@(mapcar (lambda (method)
|
||||
`(setf (,(type-class-fun-slot method)
|
||||
(type-class-or-lose ',class))
|
||||
(svref *type-classes* ,(type-class-name->id class)))
|
||||
#',name))
|
||||
(cons method more-methods)))
|
||||
',name)))
|
||||
|
|
@ -429,17 +405,16 @@
|
|||
;; Careful: type-classes are very complicated things to redefine.
|
||||
;; For the sake of parallelized make-host-1 we have to allow
|
||||
;; redefinition, but it has to be a no-op.
|
||||
(unless (find ',name *type-classes* :key #'type-class-name)
|
||||
(vector-push ,make-it *type-classes*))
|
||||
(let ((index ,(type-class-name->id name)))
|
||||
(unless (aref *type-classes* index)
|
||||
(setf (aref *type-classes* index) ,make-it)))
|
||||
;; I have no idea what compiler bug could be worked around by adding a form here,
|
||||
;; but this certainly achieves something, somehow.
|
||||
#+host-quirks-cmu (print (aref *type-classes* (1- (length *type-classes*)))))
|
||||
|
||||
#+sb-xc
|
||||
(let ((type-class-index
|
||||
(position name *type-classes* :key #'type-class-name)))
|
||||
`(!cold-init-forms
|
||||
(setf (svref *type-classes* ,type-class-index) ,make-it)))))
|
||||
`(!cold-init-forms (setf (svref *type-classes* ,(type-class-name->id name))
|
||||
,make-it))))
|
||||
|
||||
;;; Define the translation from a type-specifier to a type structure for
|
||||
;;; some particular type. Syntax is identical to DEFTYPE.
|
||||
|
|
@ -584,10 +559,10 @@
|
|||
(defun type-cache-hash (type1 type2)
|
||||
(logxor (ash (type-hash-value type1) -3) (type-hash-value type2)))
|
||||
|
||||
(declaim (inline type-list-cache-hash))
|
||||
(declaim (inline hash-ctype-list))
|
||||
(declaim (ftype (function (list) (signed-byte #.sb-vm:n-fixnum-bits))
|
||||
type-list-cache-hash))
|
||||
(defun type-list-cache-hash (types)
|
||||
hash-ctype-list))
|
||||
(defun hash-ctype-list (types)
|
||||
(loop with res of-type (signed-byte #.sb-vm:n-fixnum-bits) = 0
|
||||
for type in types
|
||||
do (setq res (logxor (ash res -1) (type-hash-value type)))
|
||||
|
|
@ -595,6 +570,60 @@
|
|||
|
||||
;;;; representations of types
|
||||
|
||||
;;; DEF-TYPE-MODEL is like DEFSTRUCT, with the following differences:
|
||||
;;; 1. it inserts (:INCLUDE CTYPE) unless otherwise expressed
|
||||
;;; 2. it inserts (:COPIER NIL)
|
||||
;;; 3. it adds :READ-ONLY T to all slots
|
||||
;;; 4. it has slot options to help with hash-consing
|
||||
(defmacro def-type-model ((name &rest options) &rest direct-slots)
|
||||
;; :CONSTRUCTOR* reminds you that it's not a direct translation to defstruct.
|
||||
(aver (<= (count :constructor* options :key #'car) 1))
|
||||
;; The private constructor is always positional.
|
||||
;; (:CONSTRUCTOR* NAME (arg1 arg2)) has a private constructor
|
||||
;; and a public constructor. The latter will eventually
|
||||
;; become a caching constructor when that change is completed.
|
||||
;; (:CONSTRUCTOR* NIL (arg1 arg2)) specifies the argument order
|
||||
;; but asks for no automatically-defined public constructor.
|
||||
;; You might hand-define one which takes &KEY args if desired.
|
||||
(let* ((public-ctor (assoc :constructor* options))
|
||||
(public-ctor-args (third public-ctor))
|
||||
(private-ctor (unless (member name '(compound-type args-type))
|
||||
(symbolicate "!ALLOC-" name)))
|
||||
(private-ctor-args (cons '%bits public-ctor-args)))
|
||||
`(progn
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(push ',(cons name direct-slots) *def-type-model-forms*))
|
||||
,@(when private-ctor `((declaim (inline ,private-ctor))))
|
||||
(defstruct (,name ,@(unless (assoc :include options) '((:include ctype)))
|
||||
,@(remove :constructor* options :key #'car)
|
||||
,(if private-ctor
|
||||
`(:constructor ,private-ctor ,private-ctor-args)
|
||||
'(:constructor nil))
|
||||
(:copier nil))
|
||||
,@(mapcar (lambda (slot &aux (copy (copy-list slot)))
|
||||
(remf copy :hasher)
|
||||
(remf copy :test)
|
||||
(append copy '(:read-only t)))
|
||||
direct-slots))
|
||||
;; If we're going to wrap the internal constructor with a hand-written one,
|
||||
;; then don't also define a caching constructor. (Extra layers are confusing).
|
||||
,@(when (second public-ctor)
|
||||
`((declaim (ftype (sfunction * ,name) ,(second public-ctor)))
|
||||
(defun ,(second public-ctor) ,public-ctor-args
|
||||
(new-ctype ,name ,@(cdr private-ctor-args))))))))
|
||||
|
||||
(defmacro new-ctype (name &rest initargs)
|
||||
;; CLASSOIDs have a deterministic hash based on the name,
|
||||
;; utilizing the same hash calculation as with LAYOUT instances.
|
||||
;; NUMBER types could compute a stable hash too (but they don't currently)
|
||||
;; which would mean that HASH-not-equal implies TYPE-not-equal.
|
||||
;; Most other things would not benefit.
|
||||
(let ((allocator (package-symbolicate "SB-KERNEL" "!ALLOC-" name)))
|
||||
`(let ((bits (logior ,(ctype-class-bits (ctype-instance-type->type-class name))
|
||||
(logand (ctype-random) +type-hash-mask+))))
|
||||
(declare (inline ,allocator))
|
||||
(,allocator bits ,@initargs))))
|
||||
|
||||
;;; The NAMED-TYPE is used to represent *, T and NIL, the standard
|
||||
;;; special cases, as well as other special cases needed to
|
||||
;;; interpolate between regions of the type hierarchy, such as
|
||||
|
|
@ -624,66 +653,49 @@
|
|||
;;; On the other hand, either of these points may not be sources of
|
||||
;;; inefficiency, and the latter if implemented might have undesirable
|
||||
;;; user-visible ramifications, though it seems unlikely.
|
||||
(defstruct (hairy-type (:include ctype)
|
||||
(:constructor %make-hairy-type
|
||||
(specifier &aux (%bits (pack-ctype-bits hairy))))
|
||||
(:constructor !make-interned-hairy-type
|
||||
(specifier &aux (%bits (pack-interned-ctype-bits 'hairy))))
|
||||
(:copier nil))
|
||||
(def-type-model (hairy-type (:constructor* %make-hairy-type (specifier)))
|
||||
;; the Common Lisp type-specifier of the type we represent.
|
||||
;; For other than an unknown type, this must be a (SATISFIES f) expression.
|
||||
(specifier nil :type t :read-only t))
|
||||
(specifier nil :type t :test equal))
|
||||
|
||||
;;; A MEMBER-TYPE represent a use of the MEMBER type specifier. We
|
||||
;;; bother with this at this level because MEMBER types are fairly
|
||||
;;; important and union and intersection are well defined.
|
||||
(defstruct (member-type (:include ctype (%bits (pack-ctype-bits member)))
|
||||
(:copier nil)
|
||||
(:constructor %make-member-type (xset fp-zeroes))
|
||||
(:constructor !make-interned-member-type (%bits xset fp-zeroes))
|
||||
#-sb-xc-host (:pure nil))
|
||||
(xset nil :type xset :read-only t)
|
||||
(fp-zeroes nil :type list :read-only t))
|
||||
(def-type-model (member-type (:constructor* %make-member-type (xset fp-zeroes)))
|
||||
(xset nil :type xset :hasher xset-elts-hash :test xset=)
|
||||
(fp-zeroes nil :type list :hasher hash-fp-zeros :test fp-zeros=))
|
||||
|
||||
;;; An ARRAY-TYPE is used to represent any array type, including
|
||||
;;; things such as SIMPLE-BASE-STRING.
|
||||
(defstruct (array-type (:include ctype (%bits (pack-ctype-bits array)))
|
||||
(:constructor %make-array-type
|
||||
(dimensions complexp element-type
|
||||
specialized-element-type))
|
||||
(:constructor !make-interned-array-type
|
||||
(%bits dimensions complexp element-type
|
||||
specialized-element-type))
|
||||
(:copier nil))
|
||||
(def-type-model (array-type
|
||||
(:constructor* %make-array-type
|
||||
(dimensions complexp element-type
|
||||
specialized-element-type)))
|
||||
;; the dimensions of the array, or * if unspecified. If a dimension
|
||||
;; is unspecified, it is *.
|
||||
(dimensions '* :type (or list (member *)) :read-only t)
|
||||
(dimensions '* :type (or list (eql *)) :test equal)
|
||||
;; Is this not a simple array type? (:MAYBE means that we don't know.)
|
||||
(complexp :maybe :type (member t nil :maybe) :read-only t)
|
||||
(complexp :maybe :type (member t nil :maybe))
|
||||
;; the element type as originally specified
|
||||
(element-type nil :type ctype :read-only t)
|
||||
(element-type nil :type ctype)
|
||||
;; the element type as it is specialized in this implementation
|
||||
(specialized-element-type nil :type ctype :read-only t))
|
||||
(specialized-element-type nil :type ctype))
|
||||
|
||||
(defstruct (character-set-type
|
||||
(:include ctype (%bits (pack-ctype-bits character-set)))
|
||||
(:constructor %make-character-set-type (pairs))
|
||||
(:constructor !make-interned-character-set-type (%bits pairs))
|
||||
(:copier nil))
|
||||
(pairs (missing-arg) :type list :read-only t))
|
||||
(def-type-model (character-set-type
|
||||
(:constructor* %make-character-set-type (pairs)))
|
||||
;; these get canonically ordered by the parser
|
||||
(pairs (missing-arg) :type list :test equal))
|
||||
|
||||
;;; A COMPOUND-TYPE is a type defined out of a set of types, the
|
||||
;;; common parent of UNION-TYPE and INTERSECTION-TYPE.
|
||||
(defstruct (compound-type (:include ctype)
|
||||
(:constructor nil)
|
||||
(:copier nil))
|
||||
(def-type-model (compound-type) ; no direct instances
|
||||
;; Formerly defined in every CTYPE, but now just in the ones
|
||||
;; for which enumerability is variable.
|
||||
(enumerable nil :read-only t)
|
||||
(enumerable nil :type boolean)
|
||||
;; This list must have at least 2 items in it.
|
||||
;; A singleton would not be a compound type.
|
||||
;; An empty OR is the type NIL, and an empty AND is type T.
|
||||
(types nil :type (cons t cons) :read-only t))
|
||||
(types nil :type (cons t cons) :hasher hash-ctype-list :test list-elts-eq))
|
||||
|
||||
;;; A UNION-TYPE represents a use of the OR type specifier which we
|
||||
;;; couldn't canonicalize to something simpler. Canonical form:
|
||||
|
|
@ -702,9 +714,9 @@
|
|||
;;; (specifier-type 'simple-string)) => T and T
|
||||
;;; even though (MEMBER #\A) is not TYPE= to BASE-CHAR.
|
||||
;;;
|
||||
(defstruct (union-type (:include compound-type (%bits (pack-ctype-bits union)))
|
||||
(:constructor make-union-type (enumerable types))
|
||||
(:copier nil)))
|
||||
(def-type-model (union-type
|
||||
(:constructor* make-union-type (enumerable types))
|
||||
(:include compound-type)))
|
||||
|
||||
;;; An INTERSECTION-TYPE represents a use of the AND type specifier
|
||||
;;; which we couldn't canonicalize to something simpler. Canonical form:
|
||||
|
|
@ -717,28 +729,26 @@
|
|||
;;; use the distributive rule to rearrange things so that
|
||||
;;; unions contain intersections and not vice versa, or we
|
||||
;;; should just punt to using a HAIRY-TYPE.
|
||||
(defstruct (intersection-type (:include compound-type
|
||||
(%bits (pack-ctype-bits intersection)))
|
||||
(:constructor %make-intersection-type
|
||||
(enumerable types))
|
||||
(:copier nil)))
|
||||
(def-type-model (intersection-type
|
||||
(:constructor* nil (enumerable types))
|
||||
(:include compound-type)))
|
||||
|
||||
(defstruct (alien-type-type
|
||||
(:include ctype (%bits (pack-ctype-bits alien)))
|
||||
(:constructor %make-alien-type-type (alien-type))
|
||||
(:copier nil))
|
||||
(alien-type nil :type alien-type :read-only t))
|
||||
(def-type-model (alien-type-type (:constructor* %make-alien-type-type (alien-type)))
|
||||
;; FIXME: this forward-references ALIEN-TYPE, and silently we're suppressing
|
||||
;; "can't open-code test of unknown type ALIEN-TYPE".
|
||||
;; It might be OK, because the "real" constructor is defined later,
|
||||
;; and it inlines the private constructor, perhaps in time to have
|
||||
;; ALIEN-TYPE be known. I'm not sure though.
|
||||
(alien-type nil :type alien-type :hasher sxhash :test eq))
|
||||
|
||||
(defstruct (negation-type (:include ctype (%bits (pack-ctype-bits negation)))
|
||||
(:copier nil)
|
||||
(:constructor make-negation-type (type)))
|
||||
(type (missing-arg) :type ctype :read-only t))
|
||||
(def-type-model (negation-type (:constructor* make-negation-type (type)))
|
||||
(type (missing-arg) :type ctype))
|
||||
|
||||
;;; An UNKNOWN-TYPE is a type not known to the type system (not yet
|
||||
;;; defined). We make this distinction since we don't want to complain
|
||||
;;; about types that are hairy but defined.
|
||||
(defstruct (unknown-type (:include hairy-type (%bits (pack-ctype-bits hairy)))
|
||||
(:copier nil)))
|
||||
(def-type-model (unknown-type (:constructor* make-unknown-type (specifier))
|
||||
(:include hairy-type)))
|
||||
|
||||
;;; a list of all the float "formats" (i.e. internal representations;
|
||||
;;; nothing to do with #'FORMAT), in order of decreasing precision
|
||||
|
|
@ -750,57 +760,53 @@
|
|||
|
||||
;;; A NUMERIC-TYPE represents any numeric type, including things
|
||||
;;; such as FIXNUM.
|
||||
(defstruct (numeric-type (:include ctype (%bits (pack-ctype-bits number)))
|
||||
(:constructor %make-numeric-type)
|
||||
(:copier nil))
|
||||
(def-type-model (numeric-type
|
||||
(:constructor* nil (enumerable class format complexp low high)))
|
||||
;; Formerly defined in every CTYPE, but now just in the ones
|
||||
;; for which enumerability is variable.
|
||||
(enumerable nil :type boolean :read-only t)
|
||||
(enumerable nil :type boolean)
|
||||
;; the kind of numeric type we have, or NIL if not specified (just
|
||||
;; NUMBER or COMPLEX)
|
||||
(class nil :type (member integer rational float nil) :read-only t)
|
||||
(class nil :type (member integer rational float nil))
|
||||
;; "format" for a float type (i.e. type specifier for a CPU
|
||||
;; representation of floating point, e.g. 'SINGLE-FLOAT -- nothing
|
||||
;; to do with #'FORMAT), or NIL if not specified or not a float.
|
||||
;; Formats which don't exist in a given implementation don't appear
|
||||
;; here.
|
||||
(format nil :type (or float-format null) :read-only t)
|
||||
(format nil :type (or float-format null) :test eq)
|
||||
;; Is this a complex numeric type? Null if unknown (only in NUMBER).
|
||||
;;
|
||||
(complexp :real :type (member :real :complex nil) :read-only t)
|
||||
(complexp :real :type (member :real :complex nil) :test eq)
|
||||
;; The upper and lower bounds on the value, or NIL if there is no
|
||||
;; bound. If a list of a number, the bound is exclusive. Integer
|
||||
;; types never have exclusive bounds, i.e. they may have them on
|
||||
;; input, but they're canonicalized to inclusive bounds before we
|
||||
;; store them here.
|
||||
(low nil :type (or real (cons real null) null) :read-only t)
|
||||
(high nil :type (or real (cons real null) null) :read-only t))
|
||||
(low nil :type (or real (cons real null) null) :test equal)
|
||||
(high nil :type (or real (cons real null) null) :test equal))
|
||||
|
||||
;;; A CONS-TYPE is used to represent a CONS type.
|
||||
(defstruct (cons-type (:include ctype (%bits (pack-ctype-bits cons)))
|
||||
(:constructor %make-cons-type (car-type cdr-type))
|
||||
(:constructor !make-interned-cons-type (%bits car-type cdr-type))
|
||||
(:copier nil))
|
||||
(def-type-model (cons-type (:constructor* nil (car-type cdr-type)))
|
||||
;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types)
|
||||
(car-type (missing-arg) :type ctype :read-only t)
|
||||
(cdr-type (missing-arg) :type ctype :read-only t))
|
||||
(car-type (missing-arg) :type ctype)
|
||||
(cdr-type (missing-arg) :type ctype))
|
||||
|
||||
(defmacro hash-ctype-or-null (x) `(let ((x ,x)) (if x (type-hash-value x) 0)))
|
||||
|
||||
;;; ARGS-TYPE objects are used both to represent VALUES types and
|
||||
;;; to represent FUNCTION types.
|
||||
(defstruct (args-type (:include ctype)
|
||||
(:constructor nil)
|
||||
(:copier nil))
|
||||
(def-type-model (args-type) ; no direct instances
|
||||
;; Lists of the type for each required and optional argument.
|
||||
(required nil :type list :read-only t)
|
||||
(optional nil :type list :read-only t)
|
||||
(required nil :type list :hasher hash-ctype-list :test list-elts-eq)
|
||||
(optional nil :type list :hasher hash-ctype-list :test list-elts-eq)
|
||||
;; The type for the rest arg. NIL if there is no &REST arg.
|
||||
(rest nil :type (or ctype null) :read-only t)
|
||||
(rest nil :type (or ctype null) :hasher hash-ctype-or-null :test eq)
|
||||
;; true if &KEY arguments are specified
|
||||
(keyp nil :type boolean :read-only t)
|
||||
(keyp nil :type boolean)
|
||||
;; list of KEY-INFO structures describing the &KEY arguments
|
||||
(keywords nil :type list :read-only t)
|
||||
(keywords nil :type list :hasher key-info-list-hash :test eq) ; hash-consed already
|
||||
;; true if other &KEY arguments are allowed
|
||||
(allowp nil :type boolean :read-only t))
|
||||
(allowp nil :type boolean))
|
||||
|
||||
;;; the description of a &KEY argument
|
||||
(declaim (inline !make-key-info))
|
||||
|
|
@ -842,66 +848,48 @@
|
|||
(when list
|
||||
(hashset-insert-if-absent *key-info-list-hashset* list #'identity)))
|
||||
|
||||
(defstruct (values-type
|
||||
(:include args-type (%bits (pack-ctype-bits values)))
|
||||
(:constructor %make-values-type)
|
||||
(:copier nil)))
|
||||
|
||||
(def-type-model (values-type (:constructor* nil (required optional rest allowp))
|
||||
(:include args-type)))
|
||||
(declaim (freeze-type values-type))
|
||||
|
||||
;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes
|
||||
(defstruct (fun-type (:include args-type (%bits (pack-ctype-bits function)))
|
||||
(:copier nil)
|
||||
(:constructor
|
||||
%make-fun-type (required optional rest
|
||||
keyp keywords allowp wild-args returns))
|
||||
(:constructor !make-interned-fun-type
|
||||
(%bits required optional rest keyp keywords
|
||||
allowp wild-args returns)))
|
||||
(def-type-model (fun-type
|
||||
(:constructor* nil (required optional rest keyp keywords allowp
|
||||
wild-args returns))
|
||||
(:include args-type))
|
||||
;; true if the arguments are unrestrictive, i.e. *
|
||||
(wild-args nil :type boolean :read-only t)
|
||||
(wild-args nil :type boolean)
|
||||
;; type describing the return values. This is a values type
|
||||
;; when multiple values were specified for the return.
|
||||
(returns (missing-arg) :type ctype :read-only t))
|
||||
(returns (missing-arg) :type ctype))
|
||||
|
||||
(defstruct (fun-designator-type
|
||||
(:include fun-type)
|
||||
(:copier nil)
|
||||
(:conc-name fun-type-)
|
||||
(:constructor make-fun-designator-type
|
||||
(required optional rest
|
||||
keyp keywords allowp wild-args returns))))
|
||||
(def-type-model (fun-designator-type
|
||||
(:constructor* nil (required optional rest keyp keywords allowp
|
||||
wild-args returns))
|
||||
(:include fun-type)))
|
||||
|
||||
;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG
|
||||
;;; "type specifier", which is only meaningful in function argument
|
||||
;;; type specifiers used within the compiler. (It represents something
|
||||
;;; that the compiler knows to be a constant.)
|
||||
(defstruct (constant-type
|
||||
(:include ctype (%bits (pack-ctype-bits constant)))
|
||||
(:copier nil))
|
||||
(def-type-model (constant-type (:constructor* nil (type)))
|
||||
;; The type which the argument must be a constant instance of for this type
|
||||
;; specifier to win.
|
||||
(type (missing-arg) :type ctype :read-only t))
|
||||
(type (missing-arg) :type ctype))
|
||||
|
||||
|
||||
;;; A SIMD-PACK-TYPE is used to represent a SIMD-PACK type.
|
||||
#+sb-simd-pack
|
||||
(defstruct (simd-pack-type
|
||||
(:include ctype (%bits (pack-ctype-bits simd-pack)))
|
||||
(:constructor %make-simd-pack-type (element-type))
|
||||
(:copier nil))
|
||||
(def-type-model (simd-pack-type
|
||||
(:constructor* %make-simd-pack-type (element-type)))
|
||||
(element-type (missing-arg)
|
||||
:type (simple-bit-vector #.(length *simd-pack-element-types*))
|
||||
:read-only t))
|
||||
:type (simple-bit-vector #.(length *simd-pack-element-types*))))
|
||||
|
||||
#+sb-simd-pack-256
|
||||
(defstruct (simd-pack-256-type
|
||||
(:include ctype (%bits (pack-ctype-bits simd-pack-256)))
|
||||
(:constructor %make-simd-pack-256-type (element-type))
|
||||
(:copier nil))
|
||||
(def-type-model (simd-pack-256-type
|
||||
(:constructor* %make-simd-pack-256-type (element-type)))
|
||||
(element-type (missing-arg)
|
||||
:type (simple-bit-vector #.(length *simd-pack-element-types*))
|
||||
:read-only t))
|
||||
:type (simple-bit-vector #.(length *simd-pack-element-types*))))
|
||||
|
||||
(declaim (ftype (sfunction (ctype ctype) (values t t)) csubtypep))
|
||||
;;; Look for nice relationships for types that have nice relationships
|
||||
|
|
@ -927,6 +915,11 @@
|
|||
|
||||
(!defun-from-collected-cold-init-forms !type-class-cold-init)
|
||||
|
||||
;;; *TYPE-CLASS-LIST* is defined only in the host. When the cross-compiler
|
||||
;;; expands TYPEP-IMPL-MACRO it get the value of this symbol from the host's
|
||||
;;; value. This function avoids a warning about a missing symbol.
|
||||
(defun type-class-name-list () (mapcar 'car (symbol-value '*type-class-list*)))
|
||||
|
||||
;;; CAUTION: unhygienic macro specifically designed to expand into body code
|
||||
;;; for TYPEP, CTYPEP (compiler-typep), or CROSS-TYPEP (cross-compiler-[c]typep)
|
||||
(defmacro typep-impl-macro ((thing &key (defaults t)) &rest more-clauses &aux seen)
|
||||
|
|
@ -1011,10 +1004,9 @@
|
|||
#-sb-xc-host
|
||||
(case (truly-the (mod ,(length *type-classes*)) (type-class-id type))
|
||||
,@(let ((clauses (mapcar #'convert-clause clauses)))
|
||||
(let ((absent (loop for class across *type-classes*
|
||||
unless (or (member (type-class-name class)
|
||||
'(values constant))
|
||||
(member (type-class-name class) seen))
|
||||
(let ((absent (loop for class in (type-class-name-list)
|
||||
unless (or (member class '(values constant))
|
||||
(member class seen))
|
||||
collect class)))
|
||||
(when absent
|
||||
(error "Unhandled type-classes: ~S" absent)))
|
||||
|
|
|
|||
|
|
@ -251,7 +251,7 @@
|
|||
`(cons (find-classoid ',super) ',guard)))
|
||||
specs)) #-sb-xc-host t)))
|
||||
(,progn-oid
|
||||
(let ((type-class (type-class-or-lose ',type-class-name)))
|
||||
(let ((type-class (!type-class-or-lose ',type-class-name)))
|
||||
(setf (type-class-complex-subtypep-arg1 type-class) #',defun-name)
|
||||
(setf (type-class-complex-subtypep-arg2 type-class)
|
||||
#'delegate-complex-subtypep-arg2)
|
||||
|
|
@ -280,8 +280,8 @@
|
|||
:hash-bits 8
|
||||
:hash-function
|
||||
(lambda (req opt rest allowp)
|
||||
(logxor (type-list-cache-hash req)
|
||||
(type-list-cache-hash opt)
|
||||
(logxor (hash-ctype-list req)
|
||||
(hash-ctype-list opt)
|
||||
(if rest
|
||||
(type-hash-value rest)
|
||||
42)
|
||||
|
|
@ -297,22 +297,16 @@
|
|||
(optional list-elts-eq)
|
||||
(rest eq)
|
||||
(allowp eq))
|
||||
(%make-values-type :required required
|
||||
:optional optional
|
||||
:rest rest
|
||||
:allowp allowp))
|
||||
(new-ctype values-type required optional rest allowp))
|
||||
|
||||
(defun make-values-type (&key required optional rest allowp)
|
||||
(multiple-value-bind (required optional rest)
|
||||
(canonicalize-args-type-args required optional rest)
|
||||
(cond ((and (null required)
|
||||
(null optional)
|
||||
(eq rest *universal-type*))
|
||||
(cond ((and (null required) (null optional) (eq rest *universal-type*))
|
||||
*wild-type*)
|
||||
((memq *empty-type* required)
|
||||
*empty-type*)
|
||||
(t (make-values-type-cached required optional
|
||||
rest allowp)))))
|
||||
(t (make-values-type-cached required optional rest allowp)))))
|
||||
|
||||
(define-type-method (values :simple-subtypep :complex-subtypep-arg1)
|
||||
(type1 type2)
|
||||
|
|
@ -528,9 +522,9 @@
|
|||
#+sb-xc-host
|
||||
(defvar *interned-fun-types*
|
||||
(flet ((fun-type (n)
|
||||
(!make-interned-fun-type (pack-interned-ctype-bits 'function)
|
||||
(make-list n :initial-element *universal-type*)
|
||||
nil nil nil nil nil nil *wild-type*)))
|
||||
(!alloc-fun-type (pack-interned-ctype-bits 'function)
|
||||
(make-list n :initial-element *universal-type*)
|
||||
nil nil nil nil nil nil *wild-type*)))
|
||||
(vector (fun-type 0) (fun-type 1) (fun-type 2) (fun-type 3))))
|
||||
|
||||
(defun make-fun-type (&key required optional rest
|
||||
|
|
@ -540,7 +534,7 @@
|
|||
(let ((rest (if (eq rest *empty-type*) nil rest))
|
||||
(n (length required)))
|
||||
(cond (designator
|
||||
(make-fun-designator-type required optional rest keyp keywords
|
||||
(new-ctype fun-designator-type required optional rest keyp keywords
|
||||
allowp wild-args returns))
|
||||
((and
|
||||
(<= n 3)
|
||||
|
|
@ -550,7 +544,7 @@
|
|||
(not (find *universal-type* required :test #'neq)))
|
||||
(svref (literal-ctype-vector *interned-fun-types*) n))
|
||||
(t
|
||||
(%make-fun-type required optional rest keyp keywords
|
||||
(new-ctype fun-type required optional rest keyp keywords
|
||||
allowp wild-args returns)))))
|
||||
|
||||
;; This seems to be used only by cltl2, and within 'cross-type',
|
||||
|
|
@ -573,7 +567,7 @@
|
|||
(type= (constant-type-type type1) (constant-type-type type2)))
|
||||
|
||||
(def-type-translator constant-arg ((:context context) type)
|
||||
(make-constant-type :type (single-value-specifier-type type context)))
|
||||
(new-ctype constant-type (single-value-specifier-type type context)))
|
||||
|
||||
(defun canonicalize-args-type-args (required optional rest &optional keyp)
|
||||
(when (eq rest *empty-type*)
|
||||
|
|
@ -1429,6 +1423,14 @@
|
|||
(defun class-classoid (class)
|
||||
(wrapper-classoid (sb-pcl::class-wrapper class))))
|
||||
|
||||
;;; HAIRY type-class has to be defined prior to defining %PARSE-TYPE.
|
||||
;; ENUMERABLE-P is T because a hairy type could be equivalent to a MEMBER type.
|
||||
;; e.g. any SATISFIES with a predicate returning T over a finite domain.
|
||||
;; But in practice there's nothing that can be done with this information,
|
||||
;; because we don't call random predicates when performing operations on types
|
||||
;; as objects, only when checking for inclusion of something in the type.
|
||||
(define-type-class hairy :enumerable t :might-contain-other-types t)
|
||||
|
||||
;;; Parsing of type specifiers comes in many variations:
|
||||
;;; SINGLE-VALUE-SPECIFIER-TYPE:
|
||||
;;; disallow VALUES even if single value, but allow *
|
||||
|
|
@ -1503,8 +1505,8 @@
|
|||
(when cl:*compile-print*
|
||||
(format t "~&; NEW UNKNOWN-TYPE ~S~%" spec))
|
||||
(setf (gethash spec table)
|
||||
(make-unknown-type :specifier spec))))))
|
||||
(make-unknown-type :specifier spec)))))
|
||||
(new-ctype unknown-type spec))))))
|
||||
(make-unknown-type spec)))))
|
||||
|
||||
;;; BASIC-PARSE-TYPESPEC can grok some simple cases that involve turning an object
|
||||
;;; used as a type specifier into an internalized type object (which might be
|
||||
|
|
@ -1811,9 +1813,13 @@ expansion happened."
|
|||
union
|
||||
nil)))
|
||||
|
||||
(define-type-class intersection
|
||||
:enumerable #'compound-type-enumerable
|
||||
:might-contain-other-types t)
|
||||
|
||||
(defun type-intersection (&rest input-types)
|
||||
(%type-intersection input-types))
|
||||
(defun-cached (%type-intersection :hash-bits 10 :hash-function #'type-list-cache-hash)
|
||||
(defun-cached (%type-intersection :hash-bits 10 :hash-function #'hash-ctype-list)
|
||||
((input-types equal))
|
||||
(let ((simplified-types (simplify-intersections input-types)))
|
||||
(declare (type list simplified-types))
|
||||
|
|
@ -1838,13 +1844,13 @@ expansion happened."
|
|||
(cond
|
||||
((null simplified-types) *universal-type*)
|
||||
((null (cdr simplified-types)) (car simplified-types))
|
||||
(t (%make-intersection-type
|
||||
(t (new-ctype intersection-type
|
||||
(some #'type-enumerable simplified-types)
|
||||
simplified-types))))))
|
||||
|
||||
(defun type-union (&rest input-types)
|
||||
(%type-union input-types))
|
||||
(defun-cached (%type-union :hash-bits 8 :hash-function #'type-list-cache-hash)
|
||||
(defun-cached (%type-union :hash-bits 8 :hash-function #'hash-ctype-list)
|
||||
((input-types equal))
|
||||
(let ((simplified-types (simplify-unions input-types)))
|
||||
(cond
|
||||
|
|
@ -2109,13 +2115,6 @@ expansion happened."
|
|||
|
||||
;;;; hairy and unknown types
|
||||
|
||||
;; ENUMERABLE-P is T because a hairy type could be equivalent to a MEMBER type.
|
||||
;; e.g. any SATISFIES with a predicate returning T over a finite domain.
|
||||
;; But in practice there's nothing that can be done with this information,
|
||||
;; because we don't call random predicates when performing operations on types
|
||||
;; as objects, only when checking for inclusion of something in the type.
|
||||
(define-type-class hairy :enumerable t :might-contain-other-types t)
|
||||
|
||||
;;; Without some special HAIRY cases, we massively pollute the type caches
|
||||
;;; with objects that are all equivalent to *EMPTY-TYPE*. e.g.
|
||||
;;; (AND (SATISFIES LEGAL-FUN-NAME-P) (SIMPLE-ARRAY CHARACTER (*))) and
|
||||
|
|
@ -2129,9 +2128,9 @@ expansion happened."
|
|||
#+sb-xc-host
|
||||
(progn
|
||||
(defvar *satisfies-keywordp-type*
|
||||
(!make-interned-hairy-type '(satisfies keywordp)))
|
||||
(!alloc-hairy-type (pack-interned-ctype-bits 'hairy) '(satisfies keywordp)))
|
||||
(defvar *fun-name-type*
|
||||
(!make-interned-hairy-type '(satisfies legal-fun-name-p))))
|
||||
(!alloc-hairy-type (pack-interned-ctype-bits 'hairy) '(satisfies legal-fun-name-p))))
|
||||
|
||||
(define-type-method (hairy :negate) (x) (make-negation-type x))
|
||||
|
||||
|
|
@ -2580,12 +2579,11 @@ expansion happened."
|
|||
(values t low)
|
||||
(values nil nil))))
|
||||
|
||||
(defun interned-numeric-type (specifier &rest args)
|
||||
(apply '%make-numeric-type
|
||||
:%bits (pack-interned-ctype-bits
|
||||
'number nil
|
||||
(when specifier (sb-vm::saetp-index-or-lose specifier)))
|
||||
args))
|
||||
(defun interned-numeric-type (specifier &key enumerable class format (complexp :real) low high)
|
||||
(!alloc-numeric-type
|
||||
(pack-interned-ctype-bits 'number nil
|
||||
(when specifier (sb-vm::saetp-index-or-lose specifier)))
|
||||
enumerable class format complexp low high))
|
||||
|
||||
#+sb-xc-host
|
||||
(progn
|
||||
|
|
@ -2798,8 +2796,7 @@ expansion happened."
|
|||
(not complexp)
|
||||
(bounds-unbounded-p low high)
|
||||
(literal-ctype (interned-numeric-type nil :complexp nil) number))))
|
||||
(%make-numeric-type :class class :format format :complexp complexp
|
||||
:low low :high high :enumerable enumerable))))
|
||||
(new-ctype numeric-type enumerable class format complexp low high))))
|
||||
|
||||
(defun modified-numeric-type (base
|
||||
&key
|
||||
|
|
@ -3537,7 +3534,7 @@ used for a COMPLEX component.~:@>"
|
|||
(unless (cdr pairs)
|
||||
(macrolet ((range (low high &optional saetp-index)
|
||||
`(return-from make-character-set-type
|
||||
(literal-ctype (!make-interned-character-set-type
|
||||
(literal-ctype (!alloc-character-set-type
|
||||
(pack-interned-ctype-bits 'character-set nil ,saetp-index)
|
||||
'((,low . ,high)))
|
||||
(character-set ((,low . ,high)))))))
|
||||
|
|
@ -3568,8 +3565,8 @@ used for a COMPLEX component.~:@>"
|
|||
(defvar *interned-array-types*
|
||||
(labels ((make-1 (type-index dims complexp type)
|
||||
(aver (= (type-saetp-index type) type-index))
|
||||
(!make-interned-array-type (pack-interned-ctype-bits 'array)
|
||||
dims complexp type type))
|
||||
(!alloc-array-type (pack-interned-ctype-bits 'array)
|
||||
dims complexp type type))
|
||||
(make-all (element-type type-index array)
|
||||
(replace array
|
||||
(list (make-1 type-index '(*) nil element-type)
|
||||
|
|
@ -4060,8 +4057,8 @@ used for a COMPLEX component.~:@>"
|
|||
(unless unpaired
|
||||
(macrolet ((member-type (&rest elts)
|
||||
`(literal-ctype
|
||||
(!make-interned-member-type
|
||||
(pack-interned-ctype-bits 'member) (xset-from-list ',elts) nil)
|
||||
(!alloc-member-type (pack-interned-ctype-bits 'member)
|
||||
(xset-from-list ',elts) nil)
|
||||
(member ,@elts))))
|
||||
(let ((elts (xset-data xset)))
|
||||
(when (singleton-p elts)
|
||||
|
|
@ -4265,10 +4262,6 @@ used for a COMPLEX component.~:@>"
|
|||
;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types
|
||||
;;;; involving AND.
|
||||
|
||||
(define-type-class intersection
|
||||
:enumerable #'compound-type-enumerable
|
||||
:might-contain-other-types t)
|
||||
|
||||
(define-type-method (intersection :negate) (type)
|
||||
(%type-union
|
||||
(mapcar #'type-negation (intersection-type-types type))))
|
||||
|
|
@ -4824,12 +4817,11 @@ used for a COMPLEX component.~:@>"
|
|||
;; but it improves the hit rate in the function caches.
|
||||
((and (type= car-type *universal-type*)
|
||||
(type= cdr-type *universal-type*))
|
||||
(literal-ctype (!make-interned-cons-type (pack-interned-ctype-bits 'cons)
|
||||
*universal-type*
|
||||
*universal-type*)
|
||||
(literal-ctype (!alloc-cons-type (pack-interned-ctype-bits 'cons)
|
||||
*universal-type* *universal-type*)
|
||||
cons))
|
||||
(t
|
||||
(%make-cons-type car-type cdr-type))))
|
||||
(new-ctype cons-type car-type cdr-type))))
|
||||
|
||||
;;; Return TYPE converted to canonical form for a situation where the
|
||||
;;; "type" '* (which SBCL still represents as a type even though ANSI
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ use_test_subdirectory
|
|||
tmpcore=$TEST_FILESTEM.core
|
||||
|
||||
run_sbcl <<EOF
|
||||
(defvar *x* (cons (sb-kernel::make-unknown-type :specifier 'hash-table) (sb-kernel:specifier-type 'hash-table)))
|
||||
(defvar *x* (cons (sb-kernel::make-unknown-type 'hash-table) (sb-kernel:specifier-type 'hash-table)))
|
||||
(save-lisp-and-die "$tmpcore")
|
||||
EOF
|
||||
run_sbcl_with_core "$tmpcore" --noinform --no-userinit --no-sysinit --noprint \
|
||||
|
|
|
|||
Loading…
Reference in a new issue