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
))
21 ;;;; implementation-dependent DEFTYPEs
23 ;;; Make DOUBLE-FLOAT a synonym for LONG-FLOAT, SINGLE-FLOAT for
24 ;;; SHORT-FLOAT. This is expanded before the translator gets a chance,
25 ;;; so we will get precedence.
27 (setf (info :type
:kind
'long-float
) :defined
)
29 (sb!xc
:deftype long-float
(&optional low high
)
30 `(double-float ,low
,high
))
31 (setf (info :type
:kind
'short-float
) :defined
)
32 (sb!xc
:deftype short-float
(&optional low high
)
33 `(single-float ,low
,high
))
35 ;;; an index into an integer
36 (sb!xc
:deftype bit-index
() `(integer 0 ,sb
!xc
:most-positive-fixnum
))
38 ;;; worst-case values for float attributes
39 (sb!xc
:deftype float-exponent
()
40 #!-long-float
'double-float-exponent
41 #!+long-float
'long-float-exponent
)
42 (sb!xc
:deftype float-digits
()
43 #!-long-float
`(integer 0 ,sb
!vm
:double-float-digits
)
44 #!+long-float
`(integer 0 ,sb
!vm
:long-float-digits
))
45 (sb!xc
:deftype float-radix
() '(integer 2 2))
46 (sb!xc
:deftype float-int-exponent
()
47 #!-long-float
'double-float-int-exponent
48 #!+long-float
'long-float-int-exponent
)
51 (sb!xc
:deftype boole-code
() '(unsigned-byte 4))
53 ;;; a byte specifier (as generated by BYTE)
54 (sb!xc
:deftype byte-specifier
() 'cons
)
56 ;;; result of CHAR-INT
57 (sb!xc
:deftype char-int
() 'char-code
)
59 ;;; PATHNAME pieces, as returned by the PATHNAME-xxx functions
60 (sb!xc
:deftype pathname-host
() '(or sb
!impl
::host null
))
61 (sb!xc
:deftype pathname-device
()
62 '(or simple-string
(member nil
:unspecific
)))
63 (sb!xc
:deftype pathname-directory
() 'list
)
64 (sb!xc
:deftype pathname-name
()
65 '(or simple-string sb
!impl
::pattern
(member nil
:unspecific
:wild
)))
66 (sb!xc
:deftype pathname-type
()
67 '(or simple-string sb
!impl
::pattern
(member nil
:unspecific
:wild
)))
68 (sb!xc
:deftype pathname-version
()
69 '(or integer
(member nil
:newest
:wild
:unspecific
)))
71 ;;; internal time format. (Note: not a FIXNUM, ouch..)
72 (sb!xc
:deftype internal-time
() 'unsigned-byte
)
74 (sb!xc
:deftype bignum-element-type
() `(unsigned-byte ,sb
!vm
:n-word-bits
))
75 (sb!xc
:deftype bignum-type
() 'bignum
)
76 ;;; FIXME: see also DEFCONSTANT MAXIMUM-BIGNUM-LENGTH in
77 ;;; src/code/bignum.lisp. -- CSR, 2004-07-19
78 (sb!xc
:deftype bignum-index
()
79 '(integer 0 #.
(1- (ash 1 (- 32 sb
!vm
:n-widetag-bits
)))))
81 ;;;; hooks into the type system
83 (sb!xc
:deftype unboxed-array
(&optional dims
)
84 (collect ((types (list 'or
)))
85 (dolist (type *specialized-array-element-types
*)
86 (when (subtypep type
'(or integer character float
(complex float
)))
87 (types `(array ,type
,dims
))))
90 (sb!xc
:deftype simple-unboxed-array
(&optional dims
)
91 (collect ((types (list 'or
)))
92 (dolist (type *specialized-array-element-types
*)
93 (when (subtypep type
'(or integer character float
(complex float
)))
94 (types `(simple-array ,type
,dims
))))
97 ;;; Return the symbol that describes the format of FLOAT.
98 (declaim (ftype (function (float) symbol
) float-format-name
))
99 (defun float-format-name (x)
101 (single-float 'single-float
)
102 (double-float 'double-float
)
103 #!+long-float
(long-float 'long-float
)))
105 ;;; This function is called when the type code wants to find out how
106 ;;; an array will actually be implemented. We set the
107 ;;; SPECIALIZED-ELEMENT-TYPE to correspond to the actual
108 ;;; specialization used in this implementation.
109 (declaim (ftype (function (array-type) array-type
) specialize-array-type
))
110 (defun specialize-array-type (type)
111 (let ((eltype (array-type-element-type type
)))
112 (setf (array-type-specialized-element-type type
)
113 (if (or (eq eltype
*wild-type
*)
114 ;; This is slightly dubious, but not as dubious as
115 ;; assuming that the upgraded-element-type should be
116 ;; equal to T, given the way that the AREF
117 ;; DERIVE-TYPE optimizer works. -- CSR, 2002-08-19
118 (unknown-type-p eltype
))
120 (dolist (stype-name *specialized-array-element-types
*
122 ;; FIXME: Mightn't it be better to have
123 ;; *SPECIALIZED-ARRAY-ELEMENT-TYPES* be stored as precalculated
124 ;; SPECIFIER-TYPE results, instead of having to calculate
125 ;; them on the fly this way? (Call the new array
126 ;; *SPECIALIZED-ARRAY-ELEMENT-SPECIFIER-TYPES* or something..)
127 (let ((stype (specifier-type stype-name
)))
128 (aver (not (unknown-type-p stype
)))
129 (when (csubtypep eltype stype
)
133 (defun sb!xc
:upgraded-array-element-type
(spec &optional environment
)
135 "Return the element type that will actually be used to implement an array
136 with the specifier :ELEMENT-TYPE Spec."
137 (declare (ignore environment
))
138 (if (unknown-type-p (specifier-type spec
))
139 (error "undefined type: ~S" spec
)
140 (type-specifier (array-type-specialized-element-type
141 (specifier-type `(array ,spec
))))))
143 (defun sb!xc
:upgraded-complex-part-type
(spec &optional environment
)
145 "Return the element type of the most specialized COMPLEX number type that
146 can hold parts of type SPEC."
147 (declare (ignore environment
))
148 (let ((type (specifier-type spec
)))
150 ((eq type
*empty-type
*) nil
)
151 ((unknown-type-p type
) (error "undefined type: ~S" spec
))
153 (let ((ctype (specifier-type `(complex ,spec
))))
155 ((eq ctype
*empty-type
*) '(eql 0))
156 ((csubtypep ctype
(specifier-type '(complex single-float
)))
158 ((csubtypep ctype
(specifier-type '(complex double-float
)))
161 ((csubtypep ctype
(specifier-type '(complex long-float
)))
163 ((csubtypep ctype
(specifier-type '(complex rational
)))
167 ;;; Return the most specific integer type that can be quickly checked that
168 ;;; includes the given type.
169 (defun containing-integer-type (subtype)
170 (dolist (type '(fixnum
174 (error "~S isn't an integer type?" subtype
))
175 (when (csubtypep subtype
(specifier-type type
))
178 ;;; If TYPE has a CHECK-xxx template, but doesn't have a corresponding
179 ;;; PRIMITIVE-TYPE, then return the template's name. Otherwise, return NIL.
180 (defun hairy-type-check-template-name (type)
181 (declare (type ctype type
))
184 (if (type= type
(specifier-type 'cons
))
188 (if (type= type
(specifier-type 'symbol
))
192 (cond ((type= type
(specifier-type 'fixnum
))
194 ((type= type
(specifier-type '(signed-byte 32)))
195 'sb
!c
:check-signed-byte-32
)
196 ((type= type
(specifier-type '(unsigned-byte 32)))
197 'sb
!c
:check-unsigned-byte-32
)