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 (!begin-collecting-cold-init-forms)
19 ;;;; FIXME: I'm not sure where to put this. -- WHN 19990817
21 (deftype sb!vm:word () `(unsigned-byte ,sb!vm:word-bits))
23 ;;;; implementation-dependent DEFTYPEs
25 ;;; Make DOUBLE-FLOAT a synonym for LONG-FLOAT, SINGLE-FLOAT for SHORT-FLOAT.
26 ;;; This is expanded before the translator gets a chance, so we will get
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 ,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))
50 (sb!xc:deftype boole-code () '(unsigned-byte 4))
52 ;;; a byte specifier (as generated by BYTE)
53 (sb!xc:deftype byte-specifier () 'cons)
55 ;;; result of CHAR-INT
56 (sb!xc:deftype char-int () 'char-code)
58 ;;; PATHNAME pieces, as returned by the PATHNAME-xxx functions
59 (sb!xc:deftype pathname-host () '(or sb!impl::host null))
60 (sb!xc:deftype pathname-device ()
61 '(or simple-string (member nil :unspecific)))
62 (sb!xc:deftype pathname-directory () 'list)
63 (sb!xc:deftype pathname-name ()
64 '(or simple-string sb!impl::pattern (member nil :unspecific :wild)))
65 (sb!xc:deftype pathname-type ()
66 '(or simple-string sb!impl::pattern (member nil :unspecific :wild)))
67 (sb!xc:deftype pathname-version ()
68 '(or integer (member nil :newest :wild :unspecific)))
70 ;;; internal time format. (Note: not a FIXNUM, ouch..)
71 (sb!xc:deftype internal-time () 'unsigned-byte)
73 (sb!xc:deftype bignum-element-type () `(unsigned-byte ,sb!vm:word-bits))
74 (sb!xc:deftype bignum-type () 'bignum)
75 (sb!xc:deftype bignum-index () 'index)
77 ;;;; hooks into the type system
79 ;;; the kinds of specialized array that actually exist in this implementation
80 (defvar *specialized-array-element-types*)
82 (setf *specialized-array-element-types*
93 (complex single-float)
94 (complex double-float)
95 #!+long-float (complex long-float)
99 #!+long-float long-float)))
101 (sb!xc:deftype unboxed-array (&optional dims)
102 (collect ((types (list 'or)))
103 (dolist (type *specialized-array-element-types*)
104 (when (subtypep type '(or integer character float (complex float)))
105 (types `(array ,type ,dims))))
108 (sb!xc:deftype simple-unboxed-array (&optional dims)
109 (collect ((types (list 'or)))
110 (dolist (type *specialized-array-element-types*)
111 (when (subtypep type '(or integer character float (complex float)))
112 (types `(simple-array ,type ,dims))))
115 ;;; Return the symbol that describes the format of FLOAT.
116 (declaim (ftype (function (float) symbol) float-format-name))
117 (defun float-format-name (x)
119 (single-float 'single-float)
120 (double-float 'double-float)
121 #!+long-float (long-float 'long-float)))
123 ;;; This function is called when the type code wants to find out how
124 ;;; an array will actually be implemented. We set the
125 ;;; Specialized-Element-Type to correspond to the actual
126 ;;; specialization used in this implementation.
127 (declaim (ftype (function (array-type) array-type) specialize-array-type))
128 (defun specialize-array-type (type)
129 (let ((eltype (array-type-element-type type)))
130 (setf (array-type-specialized-element-type type)
131 (if (eq eltype *wild-type*)
133 (dolist (stype-name *specialized-array-element-types*
134 ;; FIXME: Use *UNIVERSAL-TYPE* here?
136 ;; FIXME: Mightn't it be better to have
137 ;; *SPECIALIZED-ARRAY-ELEMENT-TYPES* be stored as precalculated
138 ;; SPECIFIER-TYPE results, instead of having to calculate
139 ;; them on the fly this way? (Call the new array
140 ;; *SPECIALIZED-ARRAY-ELEMENT-SPECIFIER-TYPES* or something..)
141 (let ((stype (specifier-type stype-name)))
142 (when (csubtypep eltype stype)
146 ;;; Return the most specific integer type that can be quickly checked that
147 ;;; includes the given type.
148 (defun containing-integer-type (subtype)
149 (dolist (type '(fixnum
153 (error "~S isn't an integer type?" subtype))
154 (when (csubtypep subtype (specifier-type type))
157 ;;; If Type has a CHECK-xxx template, but doesn't have a corresponding
158 ;;; primitive-type, then return the template's name. Otherwise, return NIL.
159 (defun hairy-type-check-template-name (type)
160 (declare (type ctype type))
162 ;; MNA: cons compound-type
163 ;; FIXIT: all commented out
165 ; (if (type= type (specifier-type 'cons))
169 ; (if (type= type (specifier-type 'symbol))
173 (case (named-type-name type)
174 (cons 'sb!c:check-cons)
175 (symbol 'sb!c:check-symbol)
178 (cond ((type= type (specifier-type 'fixnum))
180 ((type= type (specifier-type '(signed-byte 32)))
181 'sb!c:check-signed-byte-32)
182 ((type= type (specifier-type '(unsigned-byte 32)))
183 'sb!c:check-unsigned-byte-32)
186 'sb!c:check-function)
190 (!defun-from-collected-cold-init-forms !vm-type-cold-init)