1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
10 (in-package "SB-INTERPRETER")
12 ;;; The same as TYPE-ERROR but also show the variable name.
13 (define-condition interpreter-type-error
(type-error)
14 ((operation :reader type-error-operation
:initarg
:operation
)
15 (symbol :reader type-error-symbol
:initarg
:symbol
))
17 (lambda (condition stream
)
19 (ecase (type-error-operation condition
)
20 (write "~@<The value ~S for ~A is not of type ~2I~_~S.~:>")
21 (read "~@<The value of ~*~A, ~0@*~S, is not of type ~2I~_~*~S.~:>"))
22 (type-error-datum condition
)
23 (type-error-symbol condition
)
24 (type-error-expected-type condition
)))))
26 ;;; We need a bidirectional mapping between "important" CTYPEs and
27 ;;; functions that efficiently test the type, so that we aren't forced
28 ;;; to redundantly store both.
29 ;;; For example if X is declared of type INTEGER and we represented
30 ;;; that as #'INTEGERP, it should be possible to locally declare
31 ;;; that X is (MOD n) and compute that the intersection is just (MOD n),
32 ;;; which requires that we know that #'INTEGERP is the test for INTEGER.
34 ;;; We also need to ensure that TYPE is checkable at all,
35 ;;; because FUNCTION types are not good for answering questions about
36 ;;; the type of an object, only for declaring the type.
37 ;;; Passing ":STRICT NIL" to %%TYPEP won't work, because interpreted functions
38 ;;; know nothing about their type, and the non-strict test uses %FUN-TYPE.
40 ;;; The easy way of simplifying hairy FUNCTION types, namely
41 ;;; binding *UNPARSE-FUN-TYPE-SIMPLIFY* to T and then doing:
42 ;;; (VALUES-SPECIFIER-TYPE (TYPE-SPECIFIER x))
43 ;;; does not work, because ALIEN-TYPE-TYPES are incompatibly altered -
44 ;;; they fail to retain correct offsets that were manually specified.
45 ;;; Probably nobody ever cared that round-tripping was not possible,
46 ;;; because that is not an operation that the compiler needs to do,
47 ;;; though that's surprising because plenty of code exists that normalizes
48 ;;; types by unparsing and re-parsing.
50 (defun type-checker (type)
52 ((get-unary-predicate (type)
53 (dolist (entry sb-c
::*backend-type-predicates
*)
54 ;; Slowish, because there's no hashtable for TYPE=, but better
55 ;; than the alternative of not using these at all!
56 (when (type= type
(car entry
))
57 (return (symbol-function (cdr entry
))))))
60 ((or named-type numeric-type member-type classoid
61 character-set-type unknown-type hairy-type
62 alien-type-type
#+sb-simd-pack simd-pack-type
)
64 (fun-type (specifier-type 'function
))
66 (let* ((original (compound-type-types type
))
67 (new (mapcar #'simplify original
)))
68 (if (every #'eq original new
)
70 (apply (if (union-type-p type
) #'type-union
#'type-intersection
)
73 (let* ((old-car (cons-type-car-type type
))
74 (new-car (simplify old-car
))
75 (old-cdr (cons-type-cdr-type type
))
76 (new-cdr (simplify old-cdr
)))
77 (if (and (eq old-car new-car
) (eq old-cdr new-cdr
))
79 (make-cons-type new-car new-cdr
))))
81 (let* ((old-req (values-type-required type
))
82 (new-req (mapcar #'simplify old-req
))
83 (old-opt (values-type-optional type
))
84 (new-opt (mapcar #'simplify old-opt
))
85 (old-rest (values-type-rest type
))
86 (new-rest (when old-rest
(simplify old-rest
))))
87 ;; VALUES types that are not fun-types can't have &KEY.
88 (aver (and (null (sb-kernel::values-type-keyp type
))
89 (null (sb-kernel::values-type-keywords type
))
90 (null (sb-kernel::values-type-allowp type
))))
91 (if (and (every #'eq old-req new-req
)
92 (every #'eq old-opt new-opt
)
93 (eq old-rest new-rest
))
95 (make-values-type :required new-req
99 (let* ((original (array-type-element-type type
))
100 (new (simplify original
)))
101 (cond ((eq new original
) type
)
103 ;; It must have been an (ARRAY T).
104 (aver (eq (array-type-specialized-element-type type
)
106 (sb-kernel::%make-array-type
(array-type-dimensions type
)
107 (array-type-complexp type
)
108 new
*universal-type
*)))))
110 (let* ((original (negation-type-type type
))
111 (new (simplify original
)))
112 (if (eq new original
) type
(make-negation-type new
)))))))
113 (or (get-unary-predicate type
)
114 ;; If we simplify, try again for a predicate.
115 (let ((simplified (simplify type
)))
116 (or (get-unary-predicate simplified
) simplified
)))))
118 (defun specifier-from-checkfun (fun-or-ctype)
120 (if (functionp fun-or-ctype
)
121 (or (gethash (%fun-name fun-or-ctype
)
122 sb-c
::*backend-predicate-types
*)
123 (bug "No type specifier for function ~S" fun-or-ctype
))
126 (defun typecheck-fail (symbol value type
)
127 (error 'interpreter-type-error
128 :datum value
:expected-type
(specifier-from-checkfun type
)
129 :symbol symbol
:operation
'write
))
131 (defun typecheck-fail/ref
(symbol value type
)
132 (error 'interpreter-type-error
133 :datum value
:expected-type
(specifier-from-checkfun type
)
134 :symbol symbol
:operation
'read
))
136 ;; Signal an error about a form that was expected to produce multiple values
137 ;; that did not accord with their type restriction.
138 (defun values-typecheck-fail (type &rest values
)
139 ;; Maybe want to say "Received N but the VALUES type specifies M" ?
140 (let ((spec (type-specifier type
)))
142 (error 'simple-type-error
143 :format-control
"Received no value for ~S"
144 :format-arguments
(list spec
)))
146 (error 'simple-type-error
148 "The value ~S does not match the specifier ~_~S"
149 :format-arguments
(list (car values
) spec
)))
151 (error 'simple-type-error
155 "The values ~{~S~^, ~} do not match the specifier ~_~S"
156 :format-arguments
(list values spec
))))))
158 (declaim (inline itypep
)) ; Interpreter TYPEP
159 ;;; A test "function" can be be either genuinely a function, or a CTYPE.
160 (defun itypep (object test
)
162 (funcall test object
)
163 (%%typep object test
)))
165 ;; Check that VALUE is of the expected type and return it or signal an error.
166 (declaim (inline enforce-type
))
167 (defun enforce-type (value type-vector index symbol-vector
)
168 (unless (eql type-vector
+none
+)
169 (let ((type (svref type-vector index
)))
170 (unless (eql type
+none
+)
171 (unless (itypep value type
)
172 (typecheck-fail (car (svref symbol-vector index
)) value type
)))))
175 ;;;; Copy-and-pasted from sb-eval:
177 ;;; We need separate conditions for the different *-TOO-COMPLEX-ERRORs to
178 ;;; avoid spuriously triggering the handler in EVAL-IN-NATIVE-ENVIRONMENT
181 ;;; (let ((sb-ext:*evaluator-mode* :interpret))
182 ;;; (let ((fun (eval '(let ((a 1)) (lambda () a)))))
183 ;;; (eval `(compile nil ,fun))))
185 ;;; FIXME: should these be exported?
186 (define-condition interpreter-environment-too-complex-error
(simple-error)
188 (define-condition compiler-environment-too-complex-error
(simple-error)
191 (defun ip-error (format-control &rest format-arguments
)
192 (error 'sb-int
:simple-program-error
193 :format-control format-control
194 :format-arguments format-arguments
))