1 ;;;; This file contains implementation-dependent parts of the type
2 ;;;; support code. This is stuff which deals with the mapping from
3 ;;;; types defined in Common Lisp to types actually supported by an
6 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; This software is derived from the CMU CL system, which was
10 ;;;; written at Carnegie Mellon University and released into the
11 ;;;; public domain. The software is in the public domain and is
12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
13 ;;;; files for more information.
15 (in-package "SB!KERNEL")
17 ;;;; FIXME: I'm not sure where to put this. -- WHN 19990817
19 (def!type sb!vm:word () `(unsigned-byte ,sb!vm:n-word-bits))
20 (def!type sb!vm:signed-word () `(signed-byte ,sb!vm:n-word-bits))
23 ;;;; implementation-dependent DEFTYPEs
25 ;;; Make DOUBLE-FLOAT a synonym for LONG-FLOAT, SINGLE-FLOAT for
26 ;;; SHORT-FLOAT. This is expanded before the translator gets a chance,
27 ;;; so we will get precedence.
29 (setf (info :type :kind 'long-float) :defined)
31 (sb!xc:deftype long-float (&optional low high)
32 `(double-float ,low ,high))
33 (setf (info :type :kind 'short-float) :defined)
34 (sb!xc:deftype short-float (&optional low high)
35 `(single-float ,low ,high))
37 ;;; an index into an integer
38 (sb!xc:deftype bit-index () `(integer 0 ,sb!xc:most-positive-fixnum))
40 ;;; worst-case values for float attributes
41 (sb!xc:deftype float-exponent ()
42 #!-long-float 'double-float-exponent
43 #!+long-float 'long-float-exponent)
44 (sb!xc:deftype float-digits ()
45 #!-long-float `(integer 0 ,sb!vm:double-float-digits)
46 #!+long-float `(integer 0 ,sb!vm:long-float-digits))
47 (sb!xc:deftype float-radix () '(integer 2 2))
48 (sb!xc:deftype float-int-exponent ()
49 #!-long-float 'double-float-int-exponent
50 #!+long-float 'long-float-int-exponent)
53 (sb!xc:deftype boole-code () '(unsigned-byte 4))
55 ;;; a byte specifier (as generated by BYTE)
56 (sb!xc:deftype byte-specifier () 'cons)
58 ;;; result of CHAR-INT
59 (sb!xc:deftype char-int () 'char-code)
61 ;;; PATHNAME pieces, as returned by the PATHNAME-xxx functions
62 (sb!xc:deftype pathname-host () '(or sb!impl::host null))
63 (sb!xc:deftype pathname-device ()
64 '(or simple-string (member nil :unspecific :unc)))
65 (sb!xc:deftype pathname-directory () 'list)
66 (sb!xc:deftype pathname-name ()
67 '(or simple-string sb!impl::pattern (member nil :unspecific :wild)))
68 (sb!xc:deftype pathname-type ()
69 '(or simple-string sb!impl::pattern (member nil :unspecific :wild)))
70 (sb!xc:deftype pathname-version ()
71 '(or integer (member nil :newest :wild :unspecific)))
73 ;;; internal time format. (Note: not a FIXNUM, ouch..)
74 (sb!xc:deftype internal-time () 'unsigned-byte)
76 (sb!xc:deftype bignum-element-type () `(unsigned-byte ,sb!vm:n-word-bits))
77 (sb!xc:deftype bignum-type () 'bignum)
78 ;;; FIXME: see also DEFCONSTANT MAXIMUM-BIGNUM-LENGTH in
79 ;;; src/code/bignum.lisp. -- CSR, 2004-07-19
80 (sb!xc:deftype bignum-index ()
81 '(integer 0 #.(1- (ash 1 (- sb!vm:n-word-bits sb!vm:n-widetag-bits)))))
83 ;;;; hooks into the type system
85 (sb!xc:deftype unboxed-array (&optional dims)
86 (collect ((types (list 'or)))
87 (dolist (type *specialized-array-element-types*)
88 (when (subtypep type '(or integer character float (complex float)))
89 (types `(array ,type ,dims))))
92 (sb!xc:deftype simple-unboxed-array (&optional dims)
93 (collect ((types (list 'or)))
94 (dolist (type *specialized-array-element-types*)
95 (when (subtypep type '(or integer character float (complex float)))
96 (types `(simple-array ,type ,dims))))
99 (sb!xc:deftype complex-vector (&optional element-type length)
100 `(and (vector ,element-type ,length) (not simple-array)))
102 ;;; Return the symbol that describes the format of FLOAT.
103 (declaim (ftype (function (float) symbol) float-format-name))
104 (defun float-format-name (x)
106 (single-float 'single-float)
107 (double-float 'double-float)
108 #!+long-float (long-float 'long-float)))
110 (defun contains-unknown-type-p (ctype)
111 (cond ((unknown-type-p ctype) t)
112 ((intersection-type-p ctype)
113 (some #'contains-unknown-type-p (intersection-type-types ctype)))
114 ((union-type-p ctype)
115 (some #'contains-unknown-type-p (union-type-types ctype)))))
117 ;;; This function is called when the type code wants to find out how
118 ;;; an array will actually be implemented. We set the
119 ;;; SPECIALIZED-ELEMENT-TYPE to correspond to the actual
120 ;;; specialization used in this implementation.
121 (declaim (ftype (function (array-type) array-type) specialize-array-type))
122 (defun specialize-array-type (type)
123 (let ((eltype (array-type-element-type type)))
124 (setf (array-type-specialized-element-type type)
125 (if (or (eq eltype *wild-type*)
126 ;; This is slightly dubious, but not as dubious as
127 ;; assuming that the upgraded-element-type should be
128 ;; equal to T, given the way that the AREF
129 ;; DERIVE-TYPE optimizer works. -- CSR, 2002-08-19
130 (contains-unknown-type-p eltype))
132 (dolist (stype-name *specialized-array-element-types*
134 ;; FIXME: Mightn't it be better to have
135 ;; *SPECIALIZED-ARRAY-ELEMENT-TYPES* be stored as precalculated
136 ;; SPECIFIER-TYPE results, instead of having to calculate
137 ;; them on the fly this way? (Call the new array
138 ;; *SPECIALIZED-ARRAY-ELEMENT-SPECIFIER-TYPES* or something..)
139 (let ((stype (specifier-type stype-name)))
140 (aver (not (unknown-type-p stype)))
141 (when (csubtypep eltype stype)
145 (defun sb!xc:upgraded-array-element-type (spec &optional environment)
147 "Return the element type that will actually be used to implement an array
148 with the specifier :ELEMENT-TYPE Spec."
149 (declare (ignore environment))
151 ;; Can't rely on SPECIFIER-TYPE to signal PARSE-UNKNOWN-TYPE in
152 ;; the case of (AND KNOWN UNKNOWN), since the result of the
153 ;; outter call to SPECIFIER-TYPE can be cached by the code that
154 ;; doesn't catch PARSE-UNKNOWN-TYPE signal.
155 (if (contains-unknown-type-p (specifier-type spec))
156 (error "Undefined type: ~S" spec)
157 (type-specifier (array-type-specialized-element-type
158 (specifier-type `(array ,spec)))))
159 (parse-unknown-type (c)
160 (error "Undefined type: ~S" (parse-unknown-type-specifier c)))))
162 (defun sb!xc:upgraded-complex-part-type (spec &optional environment)
164 "Return the element type of the most specialized COMPLEX number type that
165 can hold parts of type SPEC."
166 (declare (ignore environment))
167 (let ((type (specifier-type spec)))
169 ((eq type *empty-type*) nil)
170 ((unknown-type-p type) (error "undefined type: ~S" spec))
172 (let ((ctype (specifier-type `(complex ,spec))))
174 ((eq ctype *empty-type*) '(eql 0))
175 ((csubtypep ctype (specifier-type '(complex single-float)))
177 ((csubtypep ctype (specifier-type '(complex double-float)))
180 ((csubtypep ctype (specifier-type '(complex long-float)))
182 ((csubtypep ctype (specifier-type '(complex rational)))
186 ;;; Return the most specific integer type that can be quickly checked that
187 ;;; includes the given type.
188 (defun containing-integer-type (subtype)
189 (dolist (type `(fixnum
190 (signed-byte ,sb!vm:n-word-bits)
191 (unsigned-byte ,sb!vm:n-word-bits)
193 (error "~S isn't an integer type?" subtype))
194 (when (csubtypep subtype (specifier-type type))
197 ;;; If TYPE has a CHECK-xxx template, but doesn't have a corresponding
198 ;;; PRIMITIVE-TYPE, then return the template's name. Otherwise, return NIL.
199 (defun hairy-type-check-template-name (type)
200 (declare (type ctype type))
203 (if (type= type (specifier-type 'cons))
207 (if (type= type (specifier-type 'symbol))
211 (cond ((type= type (specifier-type 'fixnum))
213 #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
214 ((type= type (specifier-type '(signed-byte 32)))
215 'sb!c:check-signed-byte-32)
216 #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
217 ((type= type (specifier-type '(unsigned-byte 32)))
218 'sb!c:check-unsigned-byte-32)
219 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
220 ((type= type (specifier-type '(signed-byte 64)))
221 'sb!c:check-signed-byte-64)
222 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
223 ((type= type (specifier-type '(unsigned-byte 64)))
224 'sb!c:check-unsigned-byte-64)