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 (deftype 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 ,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 (sb!xc:deftype bignum-index () 'index)
78 ;;;; hooks into the type system
80 (sb!xc:deftype unboxed-array (&optional dims)
81 (collect ((types (list 'or)))
82 (dolist (type *specialized-array-element-types*)
83 (when (subtypep type '(or integer character float (complex float)))
84 (types `(array ,type ,dims))))
87 (sb!xc:deftype simple-unboxed-array (&optional dims)
88 (collect ((types (list 'or)))
89 (dolist (type *specialized-array-element-types*)
90 (when (subtypep type '(or integer character float (complex float)))
91 (types `(simple-array ,type ,dims))))
94 ;;; Return the symbol that describes the format of FLOAT.
95 (declaim (ftype (function (float) symbol) float-format-name))
96 (defun float-format-name (x)
98 (single-float 'single-float)
99 (double-float 'double-float)
100 #!+long-float (long-float 'long-float)))
102 ;;; This function is called when the type code wants to find out how
103 ;;; an array will actually be implemented. We set the
104 ;;; SPECIALIZED-ELEMENT-TYPE to correspond to the actual
105 ;;; specialization used in this implementation.
106 (declaim (ftype (function (array-type) array-type) specialize-array-type))
107 (defun specialize-array-type (type)
108 (let ((eltype (array-type-element-type type)))
109 (setf (array-type-specialized-element-type type)
110 (if (or (eq eltype *wild-type*)
111 ;; This is slightly dubious, but not as dubious as
112 ;; assuming that the upgraded-element-type should be
113 ;; equal to T, given the way that the AREF
114 ;; DERIVE-TYPE optimizer works. -- CSR, 2002-08-19
115 (unknown-type-p eltype))
117 (dolist (stype-name *specialized-array-element-types*
119 ;; FIXME: Mightn't it be better to have
120 ;; *SPECIALIZED-ARRAY-ELEMENT-TYPES* be stored as precalculated
121 ;; SPECIFIER-TYPE results, instead of having to calculate
122 ;; them on the fly this way? (Call the new array
123 ;; *SPECIALIZED-ARRAY-ELEMENT-SPECIFIER-TYPES* or something..)
124 (let ((stype (specifier-type stype-name)))
125 (aver (not (unknown-type-p stype)))
126 (when (csubtypep eltype stype)
130 (defun sb!xc:upgraded-array-element-type (spec &optional environment)
132 "Return the element type that will actually be used to implement an array
133 with the specifier :ELEMENT-TYPE Spec."
134 (declare (ignore environment))
135 (if (unknown-type-p (specifier-type spec))
136 (error "undefined type: ~S" spec)
137 (type-specifier (array-type-specialized-element-type
138 (specifier-type `(array ,spec))))))
140 ;;; Return the most specific integer type that can be quickly checked that
141 ;;; includes the given type.
142 (defun containing-integer-type (subtype)
143 (dolist (type '(fixnum
147 (error "~S isn't an integer type?" subtype))
148 (when (csubtypep subtype (specifier-type type))
151 ;;; If TYPE has a CHECK-xxx template, but doesn't have a corresponding
152 ;;; PRIMITIVE-TYPE, then return the template's name. Otherwise, return NIL.
153 (defun hairy-type-check-template-name (type)
154 (declare (type ctype type))
157 (if (type= type (specifier-type 'cons))
161 (if (type= type (specifier-type 'symbol))
165 (cond ((type= type (specifier-type 'fixnum))
167 ((type= type (specifier-type '(signed-byte 32)))
168 'sb!c:check-signed-byte-32)
169 ((type= type (specifier-type '(unsigned-byte 32)))
170 'sb!c:check-unsigned-byte-32)