1 ;;;; This file contains the definition of the CTYPE (Compiler TYPE)
2 ;;;; structure and related macros used for manipulating it. This is
3 ;;;; sort of a mini object system with rather odd dispatching rules.
4 ;;;; Other compile-time definitions needed by multiple files are also
7 ;;;; FIXME: The comment above about what's in this file is no longer so
8 ;;;; true now that I've split off type-class.lisp. Perhaps we should
9 ;;;; split off CTYPE into the same file as type-class.lisp, rename that
10 ;;;; file to ctype.lisp, move the current comment to the head of that file,
11 ;;;; and write a new comment for this file saying how this file holds
14 ;;;; This software is part of the SBCL system. See the README file for
15 ;;;; more information.
17 ;;;; This software is derived from the CMU CL system, which was
18 ;;;; written at Carnegie Mellon University and released into the
19 ;;;; public domain. The software is in the public domain and is
20 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
21 ;;;; files for more information.
23 (in-package "SB!KERNEL")
25 (!begin-collecting-cold-init-forms)
27 ;;; Define the translation from a type-specifier to a type structure for
28 ;;; some particular type. Syntax is identical to DEFTYPE.
29 (defmacro !def-type-translator (name arglist &body body)
30 (check-type name symbol)
31 ;; FIXME: Now that the T%CL hack is ancient history and we just use CL
32 ;; instead, we can probably return to using PARSE-DEFMACRO here.
35 ;; This song and dance more or less emulates PARSE-DEFMACRO. The reason for
36 ;; doing this emulation instead of just calling PARSE-DEFMACRO is just that
37 ;; at cross-compile time PARSE-DEFMACRO expects lambda-list keywords in the
38 ;; T%CL package, which is not what we have here. Maybe there's a tidier
39 ;; solution.. (Other than wishing that ANSI had used symbols in the KEYWORD
40 ;; package as lambda list keywords, rather than using symbols in the LISP
42 (multiple-value-bind (whole wholeless-arglist)
43 (if (eq '&whole (car arglist))
44 (values (cadr arglist) (cddr arglist))
45 (values (gensym) arglist))
46 (multiple-value-bind (forms decls) (parse-body body nil)
49 (setf (info :type :translator ',name)
52 (destructuring-bind ,wholeless-arglist
53 (rest ,whole) ; discarding NAME
58 ;;; DEFVARs for these come later, after we have enough stuff defined.
59 (declaim (special *wild-type* *universal-type* *empty-type*))
61 ;;; The XXX-Type structures include the CTYPE structure for some slots that
62 ;;; apply to all types.
63 (def!struct (ctype (:conc-name type-)
65 (:make-load-form-fun make-type-load-form)
66 #-sb-xc-host (:pure t))
67 ;; The class of this type.
69 ;; FIXME: It's unnecessarily confusing to have a structure accessor
70 ;; named TYPE-CLASS-INFO which is an accessor for the CTYPE structure
71 ;; even though the TYPE-CLASS structure also exists in the system.
72 ;; Rename this slot: TYPE-CLASS or ASSOCIATED-TYPE-CLASS or something.
73 (class-info (required-argument) :type type-class)
74 ;; True if this type has a fixed number of members, and as such could
75 ;; possibly be completely specified in a MEMBER type. This is used by the
76 ;; MEMBER type methods.
77 (enumerable nil :type (member t nil) :read-only t)
78 ;; an arbitrary hash code used in EQ-style hashing of identity (since EQ
79 ;; hashing can't be done portably)
80 (hash-value (random (1+ most-positive-fixnum))
81 :type (and fixnum unsigned-byte)
83 (def!method print-object ((ctype ctype) stream)
84 (print-unreadable-object (ctype stream :type t)
85 (prin1 (type-specifier ctype) stream)))
87 ;;; Just dump it as a specifier. (We'll convert it back upon loading.)
88 (defun make-type-load-form (type)
89 (declare (type ctype type))
90 `(specifier-type ',(type-specifier type)))
94 ;;; sort of like ANY and EVERY, except:
95 ;;; * We handle two-VALUES predicate functions like SUBTYPEP. (And
96 ;;; if the result is uncertain, then we return (VALUES NIL NIL).)
97 ;;; * THING is just an atom, and we apply OP (an arity-2 function)
98 ;;; successively to THING and each element of LIST.
99 (defun any/type (op thing list)
100 (declare (type function op))
102 (dolist (i list (values nil certain?))
103 (multiple-value-bind (sub-value sub-certain?)
105 (unless sub-certain? (setf certain? nil))
106 (when sub-value (return (values t t)))))))
107 (defun every/type (op thing list)
108 (declare (type function op))
109 (dolist (i list (values t t))
110 (multiple-value-bind (sub-value sub-certain?)
112 (unless sub-certain? (return (values nil nil)))
113 (unless sub-value (return (values nil t))))))
115 ;;; Return a function like FUN, but expecting its (two) arguments in
116 ;;; the opposite order that FUN does.
118 ;;; (This looks like a sort of general utility, but currently it's
119 ;;; used only in the implementation of the type system, so it's
120 ;;; internal to SB-KERNEL. -- WHN 2001-02-13)
121 (declaim (inline swapped-args-fun))
122 (defun swapped-args-fun (fun)
123 (declare (type function fun))
127 ;;; Compute the intersection for types that intersect only when one is a
128 ;;; hierarchical subtype of the other.
129 (defun vanilla-intersection (type1 type2)
130 (multiple-value-bind (stp1 win1) (csubtypep type1 type2)
131 (multiple-value-bind (stp2 win2) (csubtypep type2 type1)
132 (cond (stp1 (values type1 t))
133 (stp2 (values type2 t))
134 ((and win1 win2) (values *empty-type* t))
136 (values type1 nil))))))
138 (defun vanilla-union (type1 type2)
139 (cond ((csubtypep type1 type2) type2)
140 ((csubtypep type2 type1) type1)
143 ;;; Hash two things (types) down to 8 bits. In CMU CL this was an EQ hash, but
144 ;;; since it now needs to run in vanilla ANSI Common Lisp at cross-compile
145 ;;; time, it's now based on the CTYPE-HASH-VALUE field instead.
147 ;;; FIXME: This was a macro in CMU CL, and is now an INLINE function. Is
148 ;;; it important for it to be INLINE, or could be become an ordinary
149 ;;; function without significant loss? -- WHN 19990413
150 #!-sb-fluid (declaim (inline type-cache-hash))
151 (declaim (ftype (function (ctype ctype) (unsigned-byte 8)) type-cache-hash))
152 (defun type-cache-hash (type1 type2)
153 (logand (logxor (ash (type-hash-value type1) -3)
154 (type-hash-value type2))
157 ;;;; cold loading initializations
159 (!defun-from-collected-cold-init-forms !typedefs-cold-init)