1 | ;;;-*- Mode: Lisp; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
4 | ;;; This file is part of OpenMCL. |
---|
5 | ;;; |
---|
6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
---|
8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
---|
10 | ;;; conflict, the preamble takes precedence. |
---|
11 | ;;; |
---|
12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
13 | ;;; |
---|
14 | ;;; The LLGPL is also available online at |
---|
15 | ;;; http://opensource.franz.com/preamble.html |
---|
16 | |
---|
17 | ;; This is a hacked-up version of the CMU CL type system. |
---|
18 | |
---|
19 | (in-package "CCL") |
---|
20 | |
---|
21 | |
---|
22 | |
---|
23 | ;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that |
---|
24 | ;;; compiler warnings can be emitted as appropriate. |
---|
25 | ;;; |
---|
26 | (define-condition parse-unknown-type (condition) |
---|
27 | ((specifier :reader parse-unknown-type-specifier :initarg :specifier)) |
---|
28 | (:report (lambda (c s) (print-unreadable-object (c s :type t) |
---|
29 | (format s "unknown type ~A" (parse-unknown-type-specifier c)))))) |
---|
30 | |
---|
31 | (defun parse-lambda-list (list) |
---|
32 | (let* ((required) |
---|
33 | (optional) |
---|
34 | (keys) |
---|
35 | (aux)) |
---|
36 | (let ((restp nil) |
---|
37 | (rest nil) |
---|
38 | (keyp nil) |
---|
39 | (allowp nil) |
---|
40 | (state :required)) |
---|
41 | (dolist (arg list) |
---|
42 | (if (and (symbolp arg) |
---|
43 | (let ((name (symbol-name arg))) |
---|
44 | (and (/= (length name) 0) |
---|
45 | (char= (char name 0) #\&)))) |
---|
46 | (case arg |
---|
47 | (&optional |
---|
48 | (unless (eq state :required) |
---|
49 | (error "Misplaced &optional in lambda-list: ~S." list)) |
---|
50 | (setq state '&optional)) |
---|
51 | (&rest |
---|
52 | (unless (member state '(:required &optional)) |
---|
53 | (error "Misplaced &rest in lambda-list: ~S." list)) |
---|
54 | (setq state '&rest)) |
---|
55 | (&key |
---|
56 | (unless (member state '(:required &optional :post-rest |
---|
57 | )) |
---|
58 | (error "Misplaced &key in lambda-list: ~S." list)) |
---|
59 | (setq keyp t) |
---|
60 | (setq state '&key)) |
---|
61 | (&allow-other-keys |
---|
62 | (unless (eq state '&key) |
---|
63 | (error "Misplaced &allow-other-keys in lambda-list: ~S." list)) |
---|
64 | (setq allowp t state '&allow-other-keys)) |
---|
65 | (&aux |
---|
66 | (when (member state '(&rest)) |
---|
67 | (error "Misplaced &aux in lambda-list: ~S." list)) |
---|
68 | (setq state '&aux)) |
---|
69 | (t |
---|
70 | (error "Unknown &keyword in lambda-list: ~S." arg))) |
---|
71 | (case state |
---|
72 | (:required (push arg required)) |
---|
73 | (&optional (push arg optional)) |
---|
74 | (&rest |
---|
75 | (setq restp t rest arg state :post-rest)) |
---|
76 | (&key (push arg keys)) |
---|
77 | (&aux (push arg aux)) |
---|
78 | (t |
---|
79 | (error "Found garbage in lambda-list when expecting a keyword: ~S." arg))))) |
---|
80 | |
---|
81 | (values (nreverse required) (nreverse optional) restp rest keyp (nreverse keys) allowp (nreverse aux))))) |
---|
82 | |
---|
83 | (defvar %deftype-expanders% (make-hash-table :test #'eq)) |
---|
84 | (defvar *type-translators* (make-hash-table :test #'eq)) |
---|
85 | (defvar *builtin-type-info* (make-hash-table :test #'equal)) |
---|
86 | (defvar %builtin-type-cells% (make-hash-table :test 'equal)) |
---|
87 | |
---|
88 | (defvar *use-implementation-types* t) |
---|
89 | |
---|
90 | (defun info-type-builtin (name) |
---|
91 | (gethash name *builtin-type-info*)) |
---|
92 | |
---|
93 | (defun (setf info-type-builtin) (val name) |
---|
94 | (setf (gethash name *builtin-type-info*) val)) |
---|
95 | |
---|
96 | (defun info-type-translator (name) |
---|
97 | (gethash name *type-translators*)) |
---|
98 | |
---|
99 | |
---|
100 | |
---|
101 | |
---|
102 | ;;; Allow bootstrapping: mostly, allow us to bootstrap the type system |
---|
103 | ;;; by having DEFTYPE expanders defined on built-in classes (the user |
---|
104 | ;;; shouldn't be allowed to do so, at least not easily. |
---|
105 | |
---|
106 | ;(defvar *type-system-initialized* nil) |
---|
107 | |
---|
108 | (defun %deftype (name fn doc) |
---|
109 | (clear-type-cache) |
---|
110 | (cond ((null fn) |
---|
111 | (remhash name %deftype-expanders%)) |
---|
112 | ((and *type-system-initialized* |
---|
113 | (or (built-in-type-p name) (find-class name nil))) |
---|
114 | (error "Cannot redefine type ~S" name)) |
---|
115 | (t (setf (gethash name %deftype-expanders%) fn) |
---|
116 | (record-source-file name 'type))) |
---|
117 | (set-documentation name 'type doc) ; nil clears it. |
---|
118 | name) |
---|
119 | |
---|
120 | (defun %define-type-translator (name fn doc) |
---|
121 | (declare (ignore doc)) |
---|
122 | (setf (gethash name *type-translators*) fn) |
---|
123 | name) |
---|
124 | |
---|
125 | ;;;(defun %deftype-expander (name) |
---|
126 | ;;; (or (gethash name %deftype-expanders%) |
---|
127 | ;;; (and *compiling-file* (%cdr (assq name *compile-time-deftype-expanders*))))) |
---|
128 | (defun %deftype-expander (name) |
---|
129 | (gethash name %deftype-expanders%)) |
---|
130 | |
---|
131 | (defun process-deftype-arglist (arglist &aux (in-optional? nil)) |
---|
132 | "Returns a NEW list similar to arglist except |
---|
133 | inserts * as the default default for &optional args." |
---|
134 | (mapcar #'(lambda (item) |
---|
135 | (cond ((eq item '&optional) (setq in-optional? t) item) |
---|
136 | ((memq item lambda-list-keywords) (setq in-optional? nil) item) |
---|
137 | ((and in-optional? (symbolp item)) (list item ''*)) |
---|
138 | (t item))) |
---|
139 | arglist)) |
---|
140 | |
---|
141 | |
---|
142 | (defun expand-type-macro (definer name arglist body env) |
---|
143 | (setq name (require-type name 'symbol)) |
---|
144 | (multiple-value-bind (lambda doc) |
---|
145 | (parse-macro-internal name arglist body env '*) |
---|
146 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
---|
147 | (,definer ',name |
---|
148 | (nfunction ,name ,lambda) |
---|
149 | ,doc)))) |
---|
150 | |
---|
151 | (defmacro deftype (name arglist &body body &environment env) |
---|
152 | "Define a new type, with syntax like DEFMACRO." |
---|
153 | (expand-type-macro '%deftype name arglist body env)) |
---|
154 | |
---|
155 | (defmacro def-type-translator (name arglist &body body &environment env) |
---|
156 | (expand-type-macro '%define-type-translator name arglist body env)) |
---|
157 | |
---|
158 | |
---|
159 | (defun type-expand (form &optional env &aux def) |
---|
160 | (while (setq def (cond ((symbolp form) |
---|
161 | (gethash form %deftype-expanders%)) |
---|
162 | ((and (consp form) (symbolp (%car form))) |
---|
163 | (gethash (%car form) %deftype-expanders%)) |
---|
164 | (t nil))) |
---|
165 | (setq form (funcall def (if (consp form) form (list form)) env))) |
---|
166 | form) |
---|
167 | |
---|
168 | (defmethod print-object ((tc type-class) stream) |
---|
169 | (print-unreadable-object (tc stream :type t :identity t) |
---|
170 | (format stream "~s" (type-class-name tc)))) |
---|
171 | |
---|
172 | (defmethod print-object ((c ctype) stream) |
---|
173 | (print-unreadable-object (c stream :type t) |
---|
174 | (format stream "~S" (type-specifier c)))) |
---|
175 | |
---|
176 | (defmethod make-load-form ((c ctype) &optional env) |
---|
177 | (declare (ignore env)) |
---|
178 | `(specifier-type ',(type-specifier c))) |
---|
179 | |
---|
180 | (defmethod make-load-form ((cell type-cell) &optional env) |
---|
181 | (declare (ignore env)) |
---|
182 | `(register-type-cell `,(type-cell-type-specifier cell))) |
---|
183 | |
---|
184 | (defmethod print-object ((cell type-cell) stream) |
---|
185 | (print-unreadable-object (cell stream :type t :identity t) |
---|
186 | (format stream "for ~s" (type-cell-type-specifier cell)))) |
---|
187 | |
---|
188 | (defun make-key-info (&key name type) |
---|
189 | (%istruct 'key-info name type)) |
---|
190 | |
---|
191 | (defun type-class-or-lose (name) |
---|
192 | (or (cdr (assq name *type-classes*)) |
---|
193 | (error "~S is not a defined type class." name))) |
---|
194 | |
---|
195 | (eval-when (:compile-toplevel :execute) |
---|
196 | |
---|
197 | (defconstant type-class-function-slots |
---|
198 | '((:simple-subtypep . #.type-class-simple-subtypep) |
---|
199 | (:complex-subtypep-arg1 . #.type-class-complex-subtypep-arg1) |
---|
200 | (:complex-subtypep-arg2 . #.type-class-complex-subtypep-arg2) |
---|
201 | (:simple-union . #.type-class-simple-union) |
---|
202 | (:complex-union . #.type-class-complex-union) |
---|
203 | (:simple-intersection . #.type-class-simple-intersection) |
---|
204 | (:complex-intersection . #.type-class-complex-intersection) |
---|
205 | (:simple-= . #.type-class-simple-=) |
---|
206 | (:complex-= . #.type-class-complex-=) |
---|
207 | (:unparse . #.type-class-unparse))) |
---|
208 | |
---|
209 | ) |
---|
210 | |
---|
211 | (defun class-typep (form class) |
---|
212 | (memq class (%inited-class-cpl (class-of form)))) |
---|
213 | |
---|
214 | ;;; CLASS-FUNCTION-SLOT-OR-LOSE -- Interface |
---|
215 | ;;; |
---|
216 | (defun class-function-slot-or-lose (name) |
---|
217 | (or (cdr (assoc name type-class-function-slots)) |
---|
218 | (error "~S is not a defined type class method." name))) |
---|
219 | |
---|
220 | |
---|
221 | (eval-when (:compile-toplevel :execute) |
---|
222 | |
---|
223 | ;;; INVOKE-TYPE-METHOD -- Interface |
---|
224 | ;;; |
---|
225 | ;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the same |
---|
226 | ;;; class, invoke the simple method. Otherwise, invoke any complex method. If |
---|
227 | ;;; there isn't a distinct complex-arg1 method, then swap the arguments when |
---|
228 | ;;; calling type1's method. If no applicable method, return DEFAULT. |
---|
229 | ;;; |
---|
230 | |
---|
231 | (defmacro invoke-type-method (simple complex-arg2 type1 type2 &key |
---|
232 | (default '(values nil t)) |
---|
233 | complex-arg1) |
---|
234 | (let ((simple (class-function-slot-or-lose simple)) |
---|
235 | (cslot1 (class-function-slot-or-lose (or complex-arg1 complex-arg2))) |
---|
236 | (cslot2 (class-function-slot-or-lose complex-arg2))) |
---|
237 | (once-only ((n-type1 type1) |
---|
238 | (n-type2 type2)) |
---|
239 | (once-only ((class1 `(ctype-class-info ,n-type1)) |
---|
240 | (class2 `(ctype-class-info ,n-type2))) |
---|
241 | `(if (eq ,class1 ,class2) |
---|
242 | (funcall (%svref ,class1 ,simple) ,n-type1 ,n-type2) |
---|
243 | ,(once-only ((complex1 `(%svref ,class1 ,cslot1)) |
---|
244 | (complex2 `(%svref ,class2 ,cslot2))) |
---|
245 | `(cond (,complex2 (funcall ,complex2 ,n-type1 ,n-type2)) |
---|
246 | (,complex1 |
---|
247 | ,(if complex-arg1 |
---|
248 | `(funcall ,complex1 ,n-type1 ,n-type2) |
---|
249 | `(funcall ,complex1 ,n-type2 ,n-type1))) |
---|
250 | (t ,default)))))))) |
---|
251 | |
---|
252 | |
---|
253 | ;;;; Utilities: |
---|
254 | |
---|
255 | ;;; ANY-TYPE-OP, EVERY-TYPE-OP -- Interface |
---|
256 | ;;; |
---|
257 | ;;; Like ANY and EVERY, except that we handle two-arg uncertain predicates. |
---|
258 | ;;; If the result is uncertain, then we return Default from the block PUNT. |
---|
259 | ;;; If LIST-FIRST is true, then the list element is the first arg, otherwise |
---|
260 | ;;; the second. |
---|
261 | ;;; |
---|
262 | (defmacro any-type-op (op thing list &key (default '(values nil nil)) |
---|
263 | list-first) |
---|
264 | (let ((n-this (gensym)) |
---|
265 | (n-thing (gensym)) |
---|
266 | (n-val (gensym)) |
---|
267 | (n-win (gensym)) |
---|
268 | (n-uncertain (gensym))) |
---|
269 | `(let ((,n-thing ,thing) |
---|
270 | (,n-uncertain nil)) |
---|
271 | (dolist (,n-this ,list |
---|
272 | (if ,n-uncertain |
---|
273 | (return-from PUNT ,default) |
---|
274 | nil)) |
---|
275 | (multiple-value-bind (,n-val ,n-win) |
---|
276 | ,(if list-first |
---|
277 | `(,op ,n-this ,n-thing) |
---|
278 | `(,op ,n-thing ,n-this)) |
---|
279 | (unless ,n-win (setq ,n-uncertain t)) |
---|
280 | (when ,n-val (return t))))))) |
---|
281 | ;;; |
---|
282 | (defmacro every-type-op (op thing list &key (default '(values nil nil)) |
---|
283 | list-first) |
---|
284 | (let ((n-this (gensym)) |
---|
285 | (n-thing (gensym)) |
---|
286 | (n-val (gensym)) |
---|
287 | (n-win (gensym))) |
---|
288 | `(let ((,n-thing ,thing)) |
---|
289 | (dolist (,n-this ,list t) |
---|
290 | (multiple-value-bind (,n-val ,n-win) |
---|
291 | ,(if list-first |
---|
292 | `(,op ,n-this ,n-thing) |
---|
293 | `(,op ,n-thing ,n-this)) |
---|
294 | (unless ,n-win (return-from PUNT ,default)) |
---|
295 | (unless ,n-val (return nil))))))) |
---|
296 | |
---|
297 | ) |
---|
298 | |
---|
299 | |
---|
300 | ;;; VANILLA-INTERSECTION -- Interface |
---|
301 | ;;; |
---|
302 | ;;; Compute the intersection for types that intersect only when one is a |
---|
303 | ;;; hierarchical subtype of the other. |
---|
304 | ;;; |
---|
305 | (defun vanilla-intersection (type1 type2) |
---|
306 | (multiple-value-bind (stp1 win1) |
---|
307 | (csubtypep type1 type2) |
---|
308 | (multiple-value-bind (stp2 win2) |
---|
309 | (csubtypep type2 type1) |
---|
310 | (cond (stp1 (values type1 t)) |
---|
311 | (stp2 (values type2 t)) |
---|
312 | ((and win1 win2) (values *empty-type* t)) |
---|
313 | (t |
---|
314 | (values type1 nil)))))) |
---|
315 | |
---|
316 | |
---|
317 | ;;; VANILLA-UNION -- Interface |
---|
318 | ;;; |
---|
319 | (defun vanilla-union (type1 type2) |
---|
320 | (cond ((csubtypep type1 type2) type2) |
---|
321 | ((csubtypep type2 type1) type1) |
---|
322 | (t nil))) |
---|
323 | |
---|
324 | (defun hierarchical-intersection2 (type1 type2) |
---|
325 | (multiple-value-bind (subtypep1 win1) (csubtypep type1 type2) |
---|
326 | (multiple-value-bind (subtypep2 win2) (csubtypep type2 type1) |
---|
327 | (cond (subtypep1 type1) |
---|
328 | (subtypep2 type2) |
---|
329 | ((and win1 win2) *empty-type*) |
---|
330 | (t nil))))) |
---|
331 | |
---|
332 | (defun hierarchical-union2 (type1 type2) |
---|
333 | (cond ((csubtypep type1 type2) type2) |
---|
334 | ((csubtypep type2 type1) type1) |
---|
335 | (t nil))) |
---|
336 | |
---|
337 | ;;; DELEGATE-COMPLEX-{SUBTYPEP-ARG2,INTERSECTION} -- Interface |
---|
338 | ;;; |
---|
339 | ;;; These functions are used as method for types which need a complex |
---|
340 | ;;; subtypep method to handle some superclasses, but cover a subtree of the |
---|
341 | ;;; type graph (i.e. there is no simple way for any other type class to be a |
---|
342 | ;;; subtype.) There are always still complex ways, namely UNION and MEMBER |
---|
343 | ;;; types, so we must give TYPE1's method a chance to run, instead of |
---|
344 | ;;; immediately returning NIL, T. |
---|
345 | ;;; |
---|
346 | (defun delegate-complex-subtypep-arg2 (type1 type2) |
---|
347 | (let ((subtypep-arg1 |
---|
348 | (type-class-complex-subtypep-arg1 |
---|
349 | (ctype-class-info type1)))) |
---|
350 | (if subtypep-arg1 |
---|
351 | (funcall subtypep-arg1 type1 type2) |
---|
352 | (values nil t)))) |
---|
353 | ;;; |
---|
354 | (defun delegate-complex-intersection (type1 type2) |
---|
355 | (let ((method (type-class-complex-intersection (ctype-class-info type1)))) |
---|
356 | (if (and method (not (eq method #'delegate-complex-intersection))) |
---|
357 | (funcall method type2 type1) |
---|
358 | (hierarchical-intersection2 type1 type2)))) |
---|
359 | |
---|
360 | ;;; HAS-SUPERCLASSES-COMPLEX-SUBTYPEP-ARG1 -- Internal |
---|
361 | ;;; |
---|
362 | ;;; Used by DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1 method. Info is |
---|
363 | ;;; a list of conses (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}). Will |
---|
364 | ;;; never be called with a hairy type as type2, since the hairy type type2 |
---|
365 | ;;; method gets first crack. |
---|
366 | ;;; |
---|
367 | #| |
---|
368 | (defun has-superclasses-complex-subtypep-arg1 (type1 type2 info) |
---|
369 | (values |
---|
370 | (and (typep type2 'class) |
---|
371 | (dolist (x info nil) |
---|
372 | (when (or (not (cdr x)) |
---|
373 | (csubtypep type1 (specifier-type (cdr x)))) |
---|
374 | (return |
---|
375 | (or (eq type2 (car x)) |
---|
376 | (let ((inherits (layout-inherits (class-layout (car x))))) |
---|
377 | (dotimes (i (length inherits) nil) |
---|
378 | (when (eq type2 (layout-class (svref inherits i))) |
---|
379 | (return t))))))))) |
---|
380 | t)) |
---|
381 | |# |
---|
382 | |
---|
383 | (eval-when (:compile-toplevel :execute) |
---|
384 | ;;; DEFINE-SUPERCLASSES -- Interface |
---|
385 | ;;; |
---|
386 | ;;; Takes a list of specs of the form (superclass &optional guard). |
---|
387 | ;;; Consider one spec (with no guard): any instance of type-class is also a |
---|
388 | ;;; subtype of SUPERCLASS and of any of its superclasses. If there are |
---|
389 | ;;; multiple specs, then some will have guards. We choose the first spec whose |
---|
390 | ;;; guard is a supertype of TYPE1 and use its superclass. In effect, a |
---|
391 | ;;; sequence of guards G0, G1, G2 is actually G0, (and G1 (not G0)), |
---|
392 | ;;; (and G2 (not (or G0 G1))). |
---|
393 | ;;; |
---|
394 | #| |
---|
395 | (defmacro define-superclasses (type-class &rest specs) |
---|
396 | (let ((info |
---|
397 | (mapcar #'(lambda (spec) |
---|
398 | (destructuring-bind (super &optional guard) |
---|
399 | spec |
---|
400 | (cons (find-class super) guard))) |
---|
401 | specs))) |
---|
402 | `(progn |
---|
403 | (setf (type-class-complex-subtypep-arg1 |
---|
404 | (type-class-or-lose ',type-class)) |
---|
405 | #'(lambda (type1 type2) |
---|
406 | (has-superclasses-complex-subtypep-arg1 type1 type2 ',info))) |
---|
407 | |
---|
408 | (setf (type-class-complex-subtypep-arg2 |
---|
409 | (type-class-or-lose ',type-class)) |
---|
410 | #'delegate-complex-subtypep-arg2) |
---|
411 | |
---|
412 | (setf (type-class-complex-intersection |
---|
413 | (type-class-or-lose ',type-class)) |
---|
414 | #'delegate-complex-intersection)))) |
---|
415 | |# |
---|
416 | |
---|
417 | ); eval-when (compile eval) |
---|
418 | |
---|
419 | |
---|
420 | (defun reparse-unknown-ctype (type) |
---|
421 | (if (unknown-ctype-p type) |
---|
422 | (specifier-type (type-specifier type)) |
---|
423 | type)) |
---|
424 | |
---|
425 | (defun swapped-args-fun (f) |
---|
426 | #'(lambda (x y) |
---|
427 | (funcall f y x))) |
---|
428 | |
---|
429 | (defun equal-but-no-car-recursion (x y) |
---|
430 | (cond ((eql x y) t) |
---|
431 | ((consp x) |
---|
432 | (and (consp y) |
---|
433 | (eql (car x) (car y)) |
---|
434 | (equal-but-no-car-recursion (cdr x) (cdr y)))) |
---|
435 | (t nil))) |
---|
436 | |
---|
437 | (defun any/type (op thing list) |
---|
438 | (declare (type function op)) |
---|
439 | (let ((certain? t)) |
---|
440 | (dolist (i list (values nil certain?)) |
---|
441 | (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) |
---|
442 | (if sub-certain? |
---|
443 | (when sub-value (return (values t t))) |
---|
444 | (setf certain? nil)))))) |
---|
445 | |
---|
446 | (defun every/type (op thing list) |
---|
447 | (declare (type function op)) |
---|
448 | (let ((certain? t)) |
---|
449 | (dolist (i list (if certain? (values t t) (values nil nil))) |
---|
450 | (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) |
---|
451 | (if sub-certain? |
---|
452 | (unless sub-value (return (values nil t))) |
---|
453 | (setf certain? nil)))))) |
---|
454 | |
---|
455 | (defun invoke-complex-=-other-method (type1 type2) |
---|
456 | (let* ((type-class (ctype-class-info type1)) |
---|
457 | (method-fun (type-class-complex-= type-class))) |
---|
458 | (if method-fun |
---|
459 | (funcall (the function method-fun) type2 type1) |
---|
460 | (values nil t)))) |
---|
461 | |
---|
462 | (defun invoke-complex-subtypep-arg1-method (type1 type2 &optional subtypep win) |
---|
463 | (let* ((type-class (ctype-class-info type1)) |
---|
464 | (method-fun (type-class-complex-subtypep-arg1 type-class))) |
---|
465 | (if method-fun |
---|
466 | (funcall (the function method-fun) type1 type2) |
---|
467 | (values subtypep win)))) |
---|
468 | |
---|
469 | (defun type-might-contain-other-types-p (type) |
---|
470 | (or (hairy-ctype-p type) |
---|
471 | (negation-ctype-p type) |
---|
472 | (union-ctype-p type) |
---|
473 | (intersection-ctype-p type))) |
---|
474 | |
---|
475 | |
---|
476 | (eval-when (:compile-toplevel :execute) |
---|
477 | |
---|
478 | (defmacro define-type-method ((class method &rest more-methods) |
---|
479 | lambda-list &body body) |
---|
480 | `(progn |
---|
481 | (let* ((fn (nfunction (,class ,method ,@more-methods) |
---|
482 | (lambda ,lambda-list ,@body)))) |
---|
483 | ,@(mapcar #'(lambda (method) |
---|
484 | `(setf (%svref |
---|
485 | (type-class-or-lose ',class) |
---|
486 | ,(class-function-slot-or-lose method)) |
---|
487 | fn)) |
---|
488 | (cons method more-methods))) |
---|
489 | nil)) |
---|
490 | |
---|
491 | ) |
---|
492 | |
---|
493 | |
---|
494 | (defun ctype-p (x) |
---|
495 | (and (eql (typecode x) target::subtag-istruct) |
---|
496 | (memq (istruct-type-name x) |
---|
497 | '#.(cons 'ctype |
---|
498 | (cons 'unknown-ctype |
---|
499 | (append (mapcar #'class-name |
---|
500 | (class-direct-subclasses (find-class 'args-ctype))) |
---|
501 | (mapcar #'class-name |
---|
502 | (class-direct-subclasses (find-class 'ctype))))))))) |
---|
503 | |
---|
504 | |
---|
505 | (setf (type-predicate 'ctype) 'ctype-p) |
---|
506 | |
---|
507 | |
---|
508 | ;;;; Function and Values types. |
---|
509 | ;;; |
---|
510 | ;;; Pretty much all of the general type operations are illegal on VALUES |
---|
511 | ;;; types, since we can't discriminate using them, do SUBTYPEP, etc. FUNCTION |
---|
512 | ;;; types are acceptable to the normal type operations, but are generally |
---|
513 | ;;; considered to be equivalent to FUNCTION. These really aren't true types in |
---|
514 | ;;; any type theoretic sense, but we still parse them into CTYPE structures for |
---|
515 | ;;; two reasons: |
---|
516 | ;;; -- Parsing and unparsing work the same way, and indeed we can't tell |
---|
517 | ;;; whether a type is a function or values type without parsing it. |
---|
518 | ;;; -- Many of the places that can be annotated with real types can also be |
---|
519 | ;;; annotated function or values types. |
---|
520 | |
---|
521 | ;; Methods on the VALUES type class. |
---|
522 | |
---|
523 | (defun make-values-ctype (&key |
---|
524 | required |
---|
525 | optional |
---|
526 | rest |
---|
527 | keyp |
---|
528 | keywords |
---|
529 | allowp) |
---|
530 | (%istruct 'values-ctype |
---|
531 | (type-class-or-lose 'values) |
---|
532 | nil |
---|
533 | required |
---|
534 | optional |
---|
535 | rest |
---|
536 | keyp |
---|
537 | keywords |
---|
538 | allowp |
---|
539 | )) |
---|
540 | |
---|
541 | (defun values-ctype-p (x) (istruct-typep x 'values-ctype)) |
---|
542 | (setf (type-predicate 'values-ctype) 'values-ctype-p) |
---|
543 | |
---|
544 | |
---|
545 | (define-type-method (values :simple-subtypep :complex-subtypep-arg1) |
---|
546 | (type1 type2) |
---|
547 | (declare (ignore type2)) |
---|
548 | (error "Subtypep is illegal on this type:~% ~S" (type-specifier type1))) |
---|
549 | |
---|
550 | (define-type-method (values :complex-subtypep-arg2) |
---|
551 | (type1 type2) |
---|
552 | (declare (ignore type1)) |
---|
553 | (error "Subtypep is illegal on this type:~% ~S" (type-specifier type2))) |
---|
554 | |
---|
555 | |
---|
556 | (define-type-method (values :unparse) (type) |
---|
557 | (cons 'values (unparse-args-types type))) |
---|
558 | |
---|
559 | |
---|
560 | ;;; TYPE=-LIST -- Internal |
---|
561 | ;;; |
---|
562 | ;;; Return true if List1 and List2 have the same elements in the same |
---|
563 | ;;; positions according to TYPE=. We return NIL, NIL if there is an uncertain |
---|
564 | ;;; comparison. |
---|
565 | ;;; |
---|
566 | (defun type=-list (list1 list2) |
---|
567 | (declare (list list1 list2)) |
---|
568 | (do ((types1 list1 (cdr types1)) |
---|
569 | (types2 list2 (cdr types2))) |
---|
570 | ((or (null types1) (null types2)) |
---|
571 | (if (or types1 types2) |
---|
572 | (values nil t) |
---|
573 | (values t t))) |
---|
574 | (multiple-value-bind (val win) |
---|
575 | (type= (first types1) (first types2)) |
---|
576 | (unless win |
---|
577 | (return (values nil nil))) |
---|
578 | (unless val |
---|
579 | (return (values nil t)))))) |
---|
580 | |
---|
581 | (define-type-method (values :simple-=) (type1 type2) |
---|
582 | (let ((rest1 (args-ctype-rest type1)) |
---|
583 | (rest2 (args-ctype-rest type2))) |
---|
584 | (cond ((or (args-ctype-keyp type1) (args-ctype-keyp type2) |
---|
585 | (args-ctype-allowp type1) (args-ctype-allowp type2)) |
---|
586 | (values nil nil)) |
---|
587 | ((and rest1 rest2 (type/= rest1 rest2)) |
---|
588 | (type= rest1 rest2)) |
---|
589 | ((or rest1 rest2) |
---|
590 | (values nil t)) |
---|
591 | (t |
---|
592 | (multiple-value-bind (req-val req-win) |
---|
593 | (type=-list (values-ctype-required type1) |
---|
594 | (values-ctype-required type2)) |
---|
595 | (multiple-value-bind (opt-val opt-win) |
---|
596 | (type=-list (values-ctype-optional type1) |
---|
597 | (values-ctype-optional type2)) |
---|
598 | (values (and req-val opt-val) (and req-win opt-win)))))))) |
---|
599 | |
---|
600 | |
---|
601 | ;; Methods on the FUNCTION type class. |
---|
602 | |
---|
603 | |
---|
604 | (defun make-function-ctype (&key |
---|
605 | required |
---|
606 | optional |
---|
607 | rest |
---|
608 | keyp |
---|
609 | keywords |
---|
610 | allowp |
---|
611 | wild-args |
---|
612 | returns) |
---|
613 | (%istruct 'function-ctype |
---|
614 | (type-class-or-lose 'function) |
---|
615 | nil |
---|
616 | required |
---|
617 | optional |
---|
618 | rest |
---|
619 | keyp |
---|
620 | keywords |
---|
621 | allowp |
---|
622 | wild-args |
---|
623 | returns |
---|
624 | )) |
---|
625 | |
---|
626 | (defun function-ctype-p (x) (istruct-typep x 'function-ctype)) |
---|
627 | (setf (type-predicate 'function-ctype) 'function-ctype-p) |
---|
628 | |
---|
629 | ;;; A flag that we can bind to cause complex function types to be unparsed as |
---|
630 | ;;; FUNCTION. Useful when we want a type that we can pass to TYPEP. |
---|
631 | ;;; |
---|
632 | (defvar *unparse-function-type-simplify* nil) |
---|
633 | |
---|
634 | (define-type-method (function :unparse) (type) |
---|
635 | (if *unparse-function-type-simplify* |
---|
636 | 'function |
---|
637 | (list 'function |
---|
638 | (if (function-ctype-wild-args type) |
---|
639 | '* |
---|
640 | (unparse-args-types type)) |
---|
641 | (type-specifier |
---|
642 | (function-ctype-returns type))))) |
---|
643 | |
---|
644 | ;;; Since all function types are equivalent to FUNCTION, they are all subtypes |
---|
645 | ;;; of each other. |
---|
646 | ;;; |
---|
647 | |
---|
648 | (define-type-method (function :simple-subtypep) (type1 type2) |
---|
649 | (flet ((fun-type-simple-p (type) |
---|
650 | (not (or (function-ctype-rest type) |
---|
651 | (function-ctype-keyp type)))) |
---|
652 | (every-csubtypep (types1 types2) |
---|
653 | (loop |
---|
654 | for a1 in types1 |
---|
655 | for a2 in types2 |
---|
656 | do (multiple-value-bind (res sure-p) |
---|
657 | (csubtypep a1 a2) |
---|
658 | (unless res (return (values res sure-p)))) |
---|
659 | finally (return (values t t))))) |
---|
660 | (macrolet ((3and (x y) |
---|
661 | `(multiple-value-bind (val1 win1) ,x |
---|
662 | (if (and (not val1) win1) |
---|
663 | (values nil t) |
---|
664 | (multiple-value-bind (val2 win2) ,y |
---|
665 | (if (and val1 val2) |
---|
666 | (values t t) |
---|
667 | (values nil (and win2 (not val2))))))))) |
---|
668 | (3and (values-subtypep (function-ctype-returns type1) |
---|
669 | (function-ctype-returns type2)) |
---|
670 | (cond ((function-ctype-wild-args type2) (values t t)) |
---|
671 | ((function-ctype-wild-args type1) |
---|
672 | (cond ((function-ctype-keyp type2) (values nil nil)) |
---|
673 | ((not (function-ctype-rest type2)) (values nil t)) |
---|
674 | ((not (null (function-ctype-required type2))) (values nil t)) |
---|
675 | (t (3and (type= *universal-type* (function-ctype-rest type2)) |
---|
676 | (every/type #'type= *universal-type* |
---|
677 | (function-ctype-optional type2)))))) |
---|
678 | ((not (and (fun-type-simple-p type1) |
---|
679 | (fun-type-simple-p type2))) |
---|
680 | (values nil nil)) |
---|
681 | (t (multiple-value-bind (min1 max1) (function-type-nargs type1) |
---|
682 | (multiple-value-bind (min2 max2) (function-type-nargs type2) |
---|
683 | (cond ((or (> max1 max2) (< min1 min2)) |
---|
684 | (values nil t)) |
---|
685 | ((and (= min1 min2) (= max1 max2)) |
---|
686 | (3and (every-csubtypep (function-ctype-required type1) |
---|
687 | (function-ctype-required type2)) |
---|
688 | (every-csubtypep (function-ctype-optional type1) |
---|
689 | (function-ctype-optional type2)))) |
---|
690 | (t (every-csubtypep |
---|
691 | (concatenate 'list |
---|
692 | (function-ctype-required type1) |
---|
693 | (function-ctype-optional type1)) |
---|
694 | (concatenate 'list |
---|
695 | (function-ctype-required type2) |
---|
696 | (function-ctype-optional type2))))))))))))) |
---|
697 | |
---|
698 | |
---|
699 | |
---|
700 | ;(define-superclasses function (function)) |
---|
701 | |
---|
702 | |
---|
703 | ;;; The union or intersection of two FUNCTION types is FUNCTION. |
---|
704 | ;;; (unless the types are type=) |
---|
705 | ;;; |
---|
706 | (define-type-method (function :simple-union) (type1 type2) |
---|
707 | (if (type= type1 type2) |
---|
708 | type1 |
---|
709 | (specifier-type 'function))) |
---|
710 | |
---|
711 | ;;; |
---|
712 | (define-type-method (function :simple-intersection) (type1 type2) |
---|
713 | (if (type= type1 type2) |
---|
714 | type1 |
---|
715 | (specifier-type 'function))) |
---|
716 | |
---|
717 | |
---|
718 | ;;; ### Not very real, but good enough for redefining transforms according to |
---|
719 | ;;; type: |
---|
720 | ;;; |
---|
721 | (define-type-method (function :simple-=) (type1 type2) |
---|
722 | (values (equalp type1 type2) t)) |
---|
723 | |
---|
724 | ;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARGUMENT "type |
---|
725 | ;;; specifier", which is only meaningful in function argument type specifiers |
---|
726 | ;;; used within the compiler. |
---|
727 | ;;; |
---|
728 | |
---|
729 | (defun clone-type-class-methods (src-tc dest-tc) |
---|
730 | (do* ((n (uvsize src-tc)) |
---|
731 | (i 2 (1+ i))) |
---|
732 | ((= i n) dest-tc) |
---|
733 | (declare (fixnum i n)) |
---|
734 | (setf (%svref dest-tc i) |
---|
735 | (%svref src-tc i)))) |
---|
736 | |
---|
737 | (clone-type-class-methods (type-class-or-lose 'values) (type-class-or-lose 'constant)) |
---|
738 | |
---|
739 | (defun make-constant-ctype (&key type) |
---|
740 | (%istruct 'constant-ctype |
---|
741 | (type-class-or-lose 'constant) |
---|
742 | nil |
---|
743 | type)) |
---|
744 | |
---|
745 | (defun constant-ctype-p (x) (istruct-typep x 'constant-ctype)) |
---|
746 | (setf (type-predicate 'constant-ctype) 'constant-ctype-p) |
---|
747 | |
---|
748 | (define-type-method (constant :unparse) (type) |
---|
749 | `(constant-argument ,(type-specifier (constant-ctype-type type)))) |
---|
750 | |
---|
751 | (define-type-method (constant :simple-=) (type1 type2) |
---|
752 | (type= (constant-ctype-type type1) (constant-ctype-type type2))) |
---|
753 | |
---|
754 | (def-type-translator constant-argument (type &environment env) |
---|
755 | (make-constant-ctype :type (specifier-type type env))) |
---|
756 | |
---|
757 | |
---|
758 | ;;; Parse-Args-Types -- Internal |
---|
759 | ;;; |
---|
760 | ;;; Given a lambda-list like values type specification and a Args-Type |
---|
761 | ;;; structure, fill in the slots in the structure accordingly. This is used |
---|
762 | ;;; for both FUNCTION and VALUES types. |
---|
763 | ;;; |
---|
764 | |
---|
765 | (defun parse-args-types (lambda-list result &optional env) |
---|
766 | (multiple-value-bind (required optional restp rest keyp keys allowp aux) |
---|
767 | (parse-lambda-list lambda-list) |
---|
768 | (when aux |
---|
769 | (error "&Aux in a FUNCTION or VALUES type: ~S." lambda-list)) |
---|
770 | (flet ((parse (spec) (specifier-type spec env))) |
---|
771 | (setf (args-ctype-required result) (mapcar #'parse required)) |
---|
772 | (setf (args-ctype-optional result) (mapcar #'parse optional)) |
---|
773 | (setf (args-ctype-rest result) (if restp (parse rest) nil)) |
---|
774 | (setf (args-ctype-keyp result) keyp) |
---|
775 | (let* ((key-info ())) |
---|
776 | (dolist (key keys) |
---|
777 | (when (or (atom key) (/= (length key) 2)) |
---|
778 | (signal-program-error "Keyword type description is not a two-list: ~S." key)) |
---|
779 | (let ((kwd (first key))) |
---|
780 | (when (member kwd key-info :test #'eq :key #'(lambda (x) (key-info-name x))) |
---|
781 | (signal-program-error "Repeated keyword ~S in lambda list: ~S." kwd lambda-list)) |
---|
782 | (push (make-key-info :name kwd |
---|
783 | :type (parse (second key))) key-info))) |
---|
784 | (setf (args-ctype-keywords result) (nreverse key-info))) |
---|
785 | (setf (args-ctype-allowp result) allowp)))) |
---|
786 | |
---|
787 | ;;; Unparse-Args-Types -- Internal |
---|
788 | ;;; |
---|
789 | ;;; Return the lambda-list like type specification corresponding |
---|
790 | ;;; to a Args-Type. |
---|
791 | ;;; |
---|
792 | (defun unparse-args-types (type) |
---|
793 | (let* ((result ())) |
---|
794 | |
---|
795 | (dolist (arg (args-ctype-required type)) |
---|
796 | (push (type-specifier arg) result)) |
---|
797 | |
---|
798 | (when (args-ctype-optional type) |
---|
799 | (push '&optional result) |
---|
800 | (dolist (arg (args-ctype-optional type)) |
---|
801 | (push (type-specifier arg) result))) |
---|
802 | |
---|
803 | (when (args-ctype-rest type) |
---|
804 | (push '&rest result) |
---|
805 | (push (type-specifier (args-ctype-rest type)) result)) |
---|
806 | |
---|
807 | (when (args-ctype-keyp type) |
---|
808 | (push '&key result) |
---|
809 | (dolist (key (args-ctype-keywords type)) |
---|
810 | (push (list (key-info-name key) |
---|
811 | (type-specifier (key-info-type key))) result))) |
---|
812 | |
---|
813 | (when (args-ctype-allowp type) |
---|
814 | (push '&allow-other-keys result)) |
---|
815 | |
---|
816 | (nreverse result))) |
---|
817 | |
---|
818 | (def-type-translator function (&optional (args '*) (result '*) &environment env) |
---|
819 | (let ((res (make-function-ctype |
---|
820 | :returns (values-specifier-type result env)))) |
---|
821 | (if (eq args '*) |
---|
822 | (setf (function-ctype-wild-args res) t) |
---|
823 | (parse-args-types args res env)) |
---|
824 | res)) |
---|
825 | |
---|
826 | (def-type-translator values (&rest values &environment env) |
---|
827 | (let ((res (make-values-ctype))) |
---|
828 | (parse-args-types values res env) |
---|
829 | (when (or (values-ctype-keyp res) (values-ctype-allowp res)) |
---|
830 | (signal-program-error "&KEY or &ALLOW-OTHER-KEYS in values type: ~s" |
---|
831 | res)) |
---|
832 | res)) |
---|
833 | |
---|
834 | ;;; Single-Value-Type -- Interface |
---|
835 | ;;; |
---|
836 | ;;; Return the type of the first value indicated by Type. This is used by |
---|
837 | ;;; people who don't want to have to deal with values types. |
---|
838 | ;;; |
---|
839 | (defun single-value-type (type) |
---|
840 | (declare (type ctype type)) |
---|
841 | (cond ((values-ctype-p type) |
---|
842 | (or (car (args-ctype-required type)) |
---|
843 | (if (args-ctype-optional type) |
---|
844 | (type-union (car (args-ctype-optional type)) |
---|
845 | (specifier-type 'null))) |
---|
846 | (args-ctype-rest type) |
---|
847 | (specifier-type 'null))) |
---|
848 | ((eq type *wild-type*) |
---|
849 | *universal-type*) |
---|
850 | (t |
---|
851 | type))) |
---|
852 | |
---|
853 | |
---|
854 | ;;; FUNCTION-TYPE-NARGS -- Interface |
---|
855 | ;;; |
---|
856 | ;;; Return the minmum number of arguments that a function can be called |
---|
857 | ;;; with, and the maximum number or NIL. If not a function type, return |
---|
858 | ;;; NIL, NIL. |
---|
859 | ;;; |
---|
860 | (defun function-type-nargs (type) |
---|
861 | (declare (type ctype type)) |
---|
862 | (if (function-ctype-p type) |
---|
863 | (let ((fixed (length (args-ctype-required type)))) |
---|
864 | (if (or (args-ctype-rest type) |
---|
865 | (args-ctype-keyp type) |
---|
866 | (args-ctype-allowp type)) |
---|
867 | (values fixed nil) |
---|
868 | (values fixed (+ fixed (length (args-ctype-optional type)))))) |
---|
869 | (values nil nil))) |
---|
870 | |
---|
871 | |
---|
872 | ;;; Values-Types -- Interface |
---|
873 | ;;; |
---|
874 | ;;; Determine if Type corresponds to a definite number of values. The first |
---|
875 | ;;; value is a list of the types for each value, and the second value is the |
---|
876 | ;;; number of values. If the number of values is not fixed, then return NIL |
---|
877 | ;;; and :Unknown. |
---|
878 | ;;; |
---|
879 | (defun values-types (type) |
---|
880 | (declare (type ctype type)) |
---|
881 | (cond ((eq type *wild-type*) |
---|
882 | (values nil :unknown)) |
---|
883 | ((not (values-ctype-p type)) |
---|
884 | (values (list type) 1)) |
---|
885 | ((or (args-ctype-optional type) |
---|
886 | (args-ctype-rest type) |
---|
887 | (args-ctype-keyp type) |
---|
888 | (args-ctype-allowp type)) |
---|
889 | (values nil :unknown)) |
---|
890 | (t |
---|
891 | (let ((req (args-ctype-required type))) |
---|
892 | (values (mapcar #'single-value-type req) (length req)))))) |
---|
893 | |
---|
894 | |
---|
895 | ;;; Values-Type-Types -- Internal |
---|
896 | ;;; |
---|
897 | ;;; Return two values: |
---|
898 | ;;; 1] A list of all the positional (fixed and optional) types. |
---|
899 | ;;; 2] The rest type (if any). If keywords allowed, *universal-type*. If no |
---|
900 | ;;; keywords or rest, *empty-type*. |
---|
901 | ;;; |
---|
902 | (defun values-type-types (type &optional (default-type *empty-type*)) |
---|
903 | (declare (type values-type type)) |
---|
904 | (values (append (args-ctype-required type) |
---|
905 | (args-ctype-optional type)) |
---|
906 | (cond ((args-ctype-keyp type) *universal-type*) |
---|
907 | ((args-ctype-rest type)) |
---|
908 | (t default-type)))) |
---|
909 | |
---|
910 | |
---|
911 | ;;; Fixed-Values-Op -- Internal |
---|
912 | ;;; |
---|
913 | ;;; Return a list of Operation applied to the types in Types1 and Types2, |
---|
914 | ;;; padding with Rest2 as needed. Types1 must not be shorter than Types2. The |
---|
915 | ;;; second value is T if Operation always returned a true second value. |
---|
916 | ;;; |
---|
917 | (defun fixed-values-op (types1 types2 rest2 operation) |
---|
918 | (declare (list types1 types2) (type ctype rest2) (type function operation)) |
---|
919 | (let ((exact t)) |
---|
920 | (values (mapcar #'(lambda (t1 t2) |
---|
921 | (multiple-value-bind (res win) |
---|
922 | (funcall operation t1 t2) |
---|
923 | (unless win (setq exact nil)) |
---|
924 | res)) |
---|
925 | types1 |
---|
926 | (append types2 |
---|
927 | (make-list (- (length types1) (length types2)) |
---|
928 | :initial-element rest2))) |
---|
929 | exact))) |
---|
930 | |
---|
931 | ;;; Coerce-To-Values -- Internal |
---|
932 | ;;; |
---|
933 | ;;; If Type isn't a values type, then make it into one: |
---|
934 | ;;; <type> ==> (values type &rest t) |
---|
935 | ;;; |
---|
936 | (defun coerce-to-values (type) |
---|
937 | (declare (type ctype type)) |
---|
938 | (if (values-ctype-p type) |
---|
939 | type |
---|
940 | (make-values-ctype :required (list type)))) |
---|
941 | |
---|
942 | |
---|
943 | ;;; Args-Type-Op -- Internal |
---|
944 | ;;; |
---|
945 | ;;; Do the specified Operation on Type1 and Type2, which may be any type, |
---|
946 | ;;; including Values types. With values types such as: |
---|
947 | ;;; (values a0 a1) |
---|
948 | ;;; (values b0 b1) |
---|
949 | ;;; |
---|
950 | ;;; We compute the more useful result: |
---|
951 | ;;; (values (<operation> a0 b0) (<operation> a1 b1)) |
---|
952 | ;;; |
---|
953 | ;;; Rather than the precise result: |
---|
954 | ;;; (<operation> (values a0 a1) (values b0 b1)) |
---|
955 | ;;; |
---|
956 | ;;; This has the virtue of always keeping the values type specifier outermost, |
---|
957 | ;;; and retains all of the information that is really useful for static type |
---|
958 | ;;; analysis. We want to know what is always true of each value independently. |
---|
959 | ;;; It is worthless to know that IF the first value is B0 then the second will |
---|
960 | ;;; be B1. |
---|
961 | ;;; |
---|
962 | ;;; If the values count signatures differ, then we produce result with the |
---|
963 | ;;; required value count chosen by Nreq when applied to the number of required |
---|
964 | ;;; values in type1 and type2. Any &key values become &rest T (anyone who uses |
---|
965 | ;;; keyword values deserves to lose.) |
---|
966 | ;;; |
---|
967 | ;;; The second value is true if the result is definitely empty or if Operation |
---|
968 | ;;; returned true as its second value each time we called it. Since we |
---|
969 | ;;; approximate the intersection of values types, the second value being true |
---|
970 | ;;; doesn't mean the result is exact. |
---|
971 | ;;; |
---|
972 | (defun args-type-op (type1 type2 operation nreq default-type) |
---|
973 | (declare (type ctype type1 type2 default-type) |
---|
974 | (type function operation nreq)) |
---|
975 | (if (eq type1 type2) |
---|
976 | (values type1 t) |
---|
977 | (if (or (values-ctype-p type1) (values-ctype-p type2)) |
---|
978 | (let ((type1 (coerce-to-values type1)) |
---|
979 | (type2 (coerce-to-values type2))) |
---|
980 | (multiple-value-bind (types1 rest1) |
---|
981 | (values-type-types type1 default-type) |
---|
982 | (multiple-value-bind (types2 rest2) |
---|
983 | (values-type-types type2 default-type) |
---|
984 | (multiple-value-bind (rest rest-exact) |
---|
985 | (funcall operation rest1 rest2) |
---|
986 | (multiple-value-bind |
---|
987 | (res res-exact) |
---|
988 | (if (< (length types1) (length types2)) |
---|
989 | (fixed-values-op types2 types1 rest1 operation) |
---|
990 | (fixed-values-op types1 types2 rest2 operation)) |
---|
991 | (let* ((req (funcall nreq |
---|
992 | (length (args-ctype-required type1)) |
---|
993 | (length (args-ctype-required type2)))) |
---|
994 | (required (subseq res 0 req)) |
---|
995 | (opt (subseq res req)) |
---|
996 | (opt-last (position rest opt :test-not #'type= |
---|
997 | :from-end t))) |
---|
998 | (if (find *empty-type* required :test #'type=) |
---|
999 | (values *empty-type* t) |
---|
1000 | (values (make-values-ctype |
---|
1001 | :required required |
---|
1002 | :optional (if opt-last |
---|
1003 | (subseq opt 0 (1+ opt-last)) |
---|
1004 | ()) |
---|
1005 | :rest (if (eq rest *empty-type*) nil rest)) |
---|
1006 | (and rest-exact res-exact))))))))) |
---|
1007 | (funcall operation type1 type2)))) |
---|
1008 | |
---|
1009 | ;;; Values-Type-Union, Values-Type-Intersection -- Interface |
---|
1010 | ;;; |
---|
1011 | ;;; Do a union or intersection operation on types that might be values |
---|
1012 | ;;; types. The result is optimized for utility rather than exactness, but it |
---|
1013 | ;;; is guaranteed that it will be no smaller (more restrictive) than the |
---|
1014 | ;;; precise result. |
---|
1015 | ;;; |
---|
1016 | |
---|
1017 | (defun values-type-union (type1 type2) |
---|
1018 | (declare (type ctype type1 type2)) |
---|
1019 | (cond ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) *wild-type*) |
---|
1020 | ((eq type1 *empty-type*) type2) |
---|
1021 | ((eq type2 *empty-type*) type1) |
---|
1022 | (t |
---|
1023 | (values (args-type-op type1 type2 #'type-union #'min *empty-type*))))) |
---|
1024 | |
---|
1025 | (defun values-type-intersection (type1 type2) |
---|
1026 | (declare (type ctype type1 type2)) |
---|
1027 | (cond ((eq type1 *wild-type*) (values type2 t)) |
---|
1028 | ((eq type2 *wild-type*) (values type1 t)) |
---|
1029 | (t |
---|
1030 | (args-type-op type1 type2 #'type-intersection #'max |
---|
1031 | (specifier-type 'null))))) |
---|
1032 | |
---|
1033 | |
---|
1034 | ;;; Values-Types-Intersect -- Interface |
---|
1035 | ;;; |
---|
1036 | ;;; Like Types-Intersect, except that it sort of works on values types. |
---|
1037 | ;;; Note that due to the semantics of Values-Type-Intersection, this might |
---|
1038 | ;;; return {T, T} when there isn't really any intersection (?). |
---|
1039 | ;;; |
---|
1040 | (defun values-types-intersect (type1 type2) |
---|
1041 | (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*)) |
---|
1042 | (values t t)) |
---|
1043 | ((or (values-ctype-p type1) (values-ctype-p type2)) |
---|
1044 | (multiple-value-bind (res win) |
---|
1045 | (values-type-intersection type1 type2) |
---|
1046 | (values (not (eq res *empty-type*)) |
---|
1047 | win))) |
---|
1048 | (t |
---|
1049 | (types-intersect type1 type2)))) |
---|
1050 | |
---|
1051 | ;;; Values-Subtypep -- Interface |
---|
1052 | ;;; |
---|
1053 | ;;; A subtypep-like operation that can be used on any types, including |
---|
1054 | ;;; values types. |
---|
1055 | ;;; |
---|
1056 | |
---|
1057 | (defun values-subtypep (type1 type2) |
---|
1058 | (declare (type ctype type1 type2)) |
---|
1059 | (cond ((eq type2 *wild-type*) (values t t)) |
---|
1060 | ((eq type1 *wild-type*) |
---|
1061 | (values (eq type2 *universal-type*) t)) |
---|
1062 | ((not (values-types-intersect type1 type2)) |
---|
1063 | (values nil t)) |
---|
1064 | (t |
---|
1065 | (if (or (values-ctype-p type1) (values-ctype-p type2)) |
---|
1066 | (let ((type1 (coerce-to-values type1)) |
---|
1067 | (type2 (coerce-to-values type2))) |
---|
1068 | (multiple-value-bind (types1 rest1) |
---|
1069 | (values-type-types type1) |
---|
1070 | (multiple-value-bind (types2 rest2) |
---|
1071 | (values-type-types type2) |
---|
1072 | (cond ((< (length (values-ctype-required type1)) |
---|
1073 | (length (values-ctype-required type2))) |
---|
1074 | (values nil t)) |
---|
1075 | ((< (length types1) (length types2)) |
---|
1076 | (values nil nil)) |
---|
1077 | ((or (values-ctype-keyp type1) |
---|
1078 | (values-ctype-keyp type2)) |
---|
1079 | (values nil nil)) |
---|
1080 | (t |
---|
1081 | (do ((t1 types1 (rest t1)) |
---|
1082 | (t2 types2 (rest t2))) |
---|
1083 | ((null t2) |
---|
1084 | (csubtypep rest1 rest2)) |
---|
1085 | (multiple-value-bind |
---|
1086 | (res win-p) |
---|
1087 | (csubtypep (first t1) (first t2)) |
---|
1088 | (unless win-p |
---|
1089 | (return (values nil nil))) |
---|
1090 | (unless res |
---|
1091 | (return (values nil t)))))))))) |
---|
1092 | (csubtypep type1 type2))))) |
---|
1093 | |
---|
1094 | |
---|
1095 | ;;;; Type method interfaces: |
---|
1096 | |
---|
1097 | ;;; Csubtypep -- Interface |
---|
1098 | ;;; |
---|
1099 | ;;; Like subtypep, only works on Type structures. |
---|
1100 | ;;; |
---|
1101 | (defun csubtypep (type1 type2) |
---|
1102 | (declare (type ctype type1 type2)) |
---|
1103 | (unless (typep type1 'ctype) |
---|
1104 | (report-bad-arg type1 'ctype)) |
---|
1105 | (unless (typep type2 'ctype) |
---|
1106 | (report-bad-arg type2 'ctype)) |
---|
1107 | (cond ((or (eq type1 type2) |
---|
1108 | (eq type1 *empty-type*) |
---|
1109 | (eq type2 *wild-type*)) |
---|
1110 | (values t t)) |
---|
1111 | (t |
---|
1112 | (invoke-type-method :simple-subtypep :complex-subtypep-arg2 |
---|
1113 | type1 type2 |
---|
1114 | :complex-arg1 :complex-subtypep-arg1)))) |
---|
1115 | |
---|
1116 | ;;; Type1 is a type-epecifier; type2 is a TYPE-CELL which may cache |
---|
1117 | ;;; a mapping between a type-specifier and a CTYPE. |
---|
1118 | (defun cell-csubtypep-2 (type-specifier type-cell) |
---|
1119 | (let* ((type1 (specifier-type type-specifier)) |
---|
1120 | (type2 (or (type-cell-ctype type-cell) |
---|
1121 | (let* ((ctype (specifier-type |
---|
1122 | (type-cell-type-specifier type-cell)))) |
---|
1123 | (when (cacheable-ctype-p ctype) |
---|
1124 | (setf (type-cell-ctype type-cell) ctype)) |
---|
1125 | ctype)))) |
---|
1126 | (cond ((or (eq type1 type2) |
---|
1127 | (eq type1 *empty-type*) |
---|
1128 | (eq type2 *wild-type*)) |
---|
1129 | (values t t)) |
---|
1130 | (t |
---|
1131 | (invoke-type-method :simple-subtypep :complex-subtypep-arg2 |
---|
1132 | type1 type2 |
---|
1133 | :complex-arg1 :complex-subtypep-arg1))))) |
---|
1134 | |
---|
1135 | |
---|
1136 | |
---|
1137 | ;;; Type= -- Interface |
---|
1138 | ;;; |
---|
1139 | ;;; If two types are definitely equivalent, return true. The second value |
---|
1140 | ;;; indicates whether the first value is definitely correct. This should only |
---|
1141 | ;;; fail in the presence of Hairy types. |
---|
1142 | ;;; |
---|
1143 | |
---|
1144 | (defun type= (type1 type2) |
---|
1145 | (declare (type ctype type1 type2)) |
---|
1146 | (if (eq type1 type2) |
---|
1147 | (values t t) |
---|
1148 | (invoke-type-method :simple-= :complex-= type1 type2))) |
---|
1149 | |
---|
1150 | ;;; TYPE/= -- Interface |
---|
1151 | ;;; |
---|
1152 | ;;; Not exactly the negation of TYPE=, since when the relationship is |
---|
1153 | ;;; uncertain, we still return NIL, NIL. This is useful in cases where the |
---|
1154 | ;;; conservative assumption is =. |
---|
1155 | ;;; |
---|
1156 | (defun type/= (type1 type2) |
---|
1157 | (declare (type ctype type1 type2)) |
---|
1158 | (multiple-value-bind (res win) |
---|
1159 | (type= type1 type2) |
---|
1160 | (if win |
---|
1161 | (values (not res) t) |
---|
1162 | (values nil nil)))) |
---|
1163 | |
---|
1164 | ;;; Type-Union -- Interface |
---|
1165 | ;;; |
---|
1166 | ;;; Find a type which includes both types. Any inexactness is represented |
---|
1167 | ;;; by the fuzzy element types; we return a single value that is precise to the |
---|
1168 | ;;; best of our knowledge. This result is simplified into the canonical form, |
---|
1169 | ;;; thus is not a UNION type unless there is no other way to represent the |
---|
1170 | ;;; result. |
---|
1171 | ;;; |
---|
1172 | |
---|
1173 | (defun type-union (&rest input-types) |
---|
1174 | (%type-union input-types)) |
---|
1175 | |
---|
1176 | (defun %type-union (input-types) |
---|
1177 | (let* ((simplified (simplify-unions input-types))) |
---|
1178 | (cond ((null simplified) *empty-type*) |
---|
1179 | ((null (cdr simplified)) (car simplified)) |
---|
1180 | (t (make-union-ctype simplified))))) |
---|
1181 | |
---|
1182 | (defun simplify-unions (types) |
---|
1183 | (when types |
---|
1184 | (multiple-value-bind (first rest) |
---|
1185 | (if (union-ctype-p (car types)) |
---|
1186 | (values (car (union-ctype-types (car types))) |
---|
1187 | (append (cdr (union-ctype-types (car types))) |
---|
1188 | (cdr types))) |
---|
1189 | (values (car types) (cdr types))) |
---|
1190 | (let ((rest (simplify-unions rest)) u) |
---|
1191 | (dolist (r rest (cons first rest)) |
---|
1192 | (when (setq u (type-union2 first r)) |
---|
1193 | (return (simplify-unions (nsubstitute u r rest))))))))) |
---|
1194 | |
---|
1195 | (defun type-union2 (type1 type2) |
---|
1196 | (declare (type ctype type1 type2)) |
---|
1197 | (setq type1 (reparse-unknown-ctype type1)) |
---|
1198 | (setq type2 (reparse-unknown-ctype type2)) |
---|
1199 | (cond ((eq type1 type2) type1) |
---|
1200 | ((csubtypep type1 type2) type2) |
---|
1201 | ((csubtypep type2 type1) type1) |
---|
1202 | (t |
---|
1203 | (flet ((1way (x y) |
---|
1204 | (invoke-type-method :simple-union :complex-union |
---|
1205 | x y |
---|
1206 | :default nil))) |
---|
1207 | (or (1way type1 type2) |
---|
1208 | (1way type2 type1)))))) |
---|
1209 | |
---|
1210 | ;;; Return as restrictive and simple a type as we can discover that is |
---|
1211 | ;;; no more restrictive than the intersection of TYPE1 and TYPE2. At |
---|
1212 | ;;; worst, we arbitrarily return one of the arguments as the first |
---|
1213 | ;;; value (trying not to return a hairy type). |
---|
1214 | (defun type-approx-intersection2 (type1 type2) |
---|
1215 | (cond ((type-intersection2 type1 type2)) |
---|
1216 | ((hairy-ctype-p type1) type2) |
---|
1217 | (t type1))) |
---|
1218 | |
---|
1219 | |
---|
1220 | ;;; Type-Intersection -- Interface |
---|
1221 | ;;; |
---|
1222 | ;;; Return as restrictive a type as we can discover that is no more |
---|
1223 | ;;; restrictive than the intersection of Type1 and Type2. The second value is |
---|
1224 | ;;; true if the result is exact. At worst, we randomly return one of the |
---|
1225 | ;;; arguments as the first value (trying not to return a hairy type). |
---|
1226 | ;;; |
---|
1227 | |
---|
1228 | (defun type-intersection (&rest input-types) |
---|
1229 | (%type-intersection input-types)) |
---|
1230 | |
---|
1231 | (defun %type-intersection (input-types) |
---|
1232 | (let ((simplified (simplify-intersections input-types))) |
---|
1233 | ;;(declare (type (vector ctype) simplified)) |
---|
1234 | ;; We want to have a canonical representation of types (or failing |
---|
1235 | ;; that, punt to HAIRY-TYPE). Canonical representation would have |
---|
1236 | ;; intersections inside unions but not vice versa, since you can |
---|
1237 | ;; always achieve that by the distributive rule. But we don't want |
---|
1238 | ;; to just apply the distributive rule, since it would be too easy |
---|
1239 | ;; to end up with unreasonably huge type expressions. So instead |
---|
1240 | ;; we try to generate a simple type by distributing the union; if |
---|
1241 | ;; the type can't be made simple, we punt to HAIRY-TYPE. |
---|
1242 | (if (and (cdr simplified) (some #'union-ctype-p simplified)) |
---|
1243 | (let* ((first-union (find-if #'union-ctype-p simplified)) |
---|
1244 | (other-types (remove first-union simplified)) |
---|
1245 | (distributed (maybe-distribute-one-union first-union other-types))) |
---|
1246 | (if distributed |
---|
1247 | (apply #'type-union distributed) |
---|
1248 | (make-hairy-ctype |
---|
1249 | :specifier `(and ,@(mapcar #'type-specifier simplified))))) |
---|
1250 | (cond |
---|
1251 | ((null simplified) *universal-type*) |
---|
1252 | ((null (cdr simplified)) (car simplified)) |
---|
1253 | (t (make-intersection-ctype |
---|
1254 | (some #'(lambda (c) (ctype-enumerable c)) simplified) |
---|
1255 | simplified)))))) |
---|
1256 | |
---|
1257 | (defun simplify-intersections (types) |
---|
1258 | (when types |
---|
1259 | (multiple-value-bind (first rest) |
---|
1260 | (if (intersection-ctype-p (car types)) |
---|
1261 | (values (car (intersection-ctype-types (car types))) |
---|
1262 | (append (cdr (intersection-ctype-types (car types))) |
---|
1263 | (cdr types))) |
---|
1264 | (values (car types) (cdr types))) |
---|
1265 | (let ((rest (simplify-intersections rest)) u) |
---|
1266 | (dolist (r rest (cons first rest)) |
---|
1267 | (when (setq u (type-intersection2 first r)) |
---|
1268 | (return (simplify-intersections (nsubstitute u r rest))))))))) |
---|
1269 | |
---|
1270 | (defun type-intersection2 (type1 type2) |
---|
1271 | (declare (type ctype type1 type2)) |
---|
1272 | (setq type1 (reparse-unknown-ctype type1)) |
---|
1273 | (setq type2 (reparse-unknown-ctype type2)) |
---|
1274 | (cond ((eq type1 type2) |
---|
1275 | type1) |
---|
1276 | ((or (intersection-ctype-p type1) |
---|
1277 | (intersection-ctype-p type2)) |
---|
1278 | ;; Intersections of INTERSECTION-TYPE should have the |
---|
1279 | ;; INTERSECTION-CTYPE-TYPES values broken out and intersected |
---|
1280 | ;; separately. The full TYPE-INTERSECTION function knows how |
---|
1281 | ;; to do that, so let it handle it. |
---|
1282 | (type-intersection type1 type2)) |
---|
1283 | ;; |
---|
1284 | ;; (AND (FUNCTION (T) T) GENERIC-FUNCTION) for instance, but |
---|
1285 | ;; not (AND (FUNCTION (T) T) (FUNCTION (T) T)). |
---|
1286 | ((let ((function (specifier-type 'function))) |
---|
1287 | (or (and (function-ctype-p type1) |
---|
1288 | (not (or (function-ctype-p type2) (eq function type2))) |
---|
1289 | (csubtypep type2 function) |
---|
1290 | (not (csubtypep function type2))) |
---|
1291 | (and (function-ctype-p type2) |
---|
1292 | (not (or (function-ctype-p type1) (eq function type1))) |
---|
1293 | (csubtypep type1 function) |
---|
1294 | (not (csubtypep function type1))))) |
---|
1295 | nil) |
---|
1296 | (t |
---|
1297 | (flet ((1way (x y) |
---|
1298 | (invoke-type-method :simple-intersection |
---|
1299 | :complex-intersection |
---|
1300 | x y |
---|
1301 | :default :no-type-method-found))) |
---|
1302 | (let ((xy (1way type1 type2))) |
---|
1303 | (or (and (not (eql xy :no-type-method-found)) xy) |
---|
1304 | (let ((yx (1way type2 type1))) |
---|
1305 | (or (and (not (eql yx :no-type-method-found)) yx) |
---|
1306 | (cond ((and (eql xy :no-type-method-found) |
---|
1307 | (eql yx :no-type-method-found)) |
---|
1308 | *empty-type*) |
---|
1309 | (t |
---|
1310 | nil)))))))))) |
---|
1311 | |
---|
1312 | |
---|
1313 | |
---|
1314 | (defun maybe-distribute-one-union (union-type types) |
---|
1315 | (let* ((intersection (apply #'type-intersection types)) |
---|
1316 | (union (mapcar (lambda (x) (type-intersection x intersection)) |
---|
1317 | (union-ctype-types union-type)))) |
---|
1318 | (if (notany (lambda (x) |
---|
1319 | (or (hairy-ctype-p x) |
---|
1320 | (intersection-ctype-p x))) |
---|
1321 | union) |
---|
1322 | union |
---|
1323 | nil))) |
---|
1324 | |
---|
1325 | ;;; Types-Intersect -- Interface |
---|
1326 | ;;; |
---|
1327 | ;;; The first value is true unless the types don't intersect. The second |
---|
1328 | ;;; value is true if the first value is definitely correct. NIL is considered |
---|
1329 | ;;; to intersect with any type. If T is a subtype of either type, then we also |
---|
1330 | ;;; return T, T. This way we consider hairy types to intersect with T. |
---|
1331 | ;;; |
---|
1332 | (defun types-intersect (type1 type2) |
---|
1333 | (declare (type ctype type1 type2)) |
---|
1334 | (if (or (eq type1 *empty-type*) (eq type2 *empty-type*)) |
---|
1335 | (values t t) |
---|
1336 | (let ((intersection2 (type-intersection2 type1 type2))) |
---|
1337 | (cond ((not intersection2) |
---|
1338 | (if (or (csubtypep *universal-type* type1) |
---|
1339 | (csubtypep *universal-type* type2)) |
---|
1340 | (values t t) |
---|
1341 | (values t nil))) |
---|
1342 | ((eq intersection2 *empty-type*) (values nil t)) |
---|
1343 | (t (values t t)))))) |
---|
1344 | |
---|
1345 | ;;; Type-Specifier -- Interface |
---|
1346 | ;;; |
---|
1347 | ;;; Return a Common Lisp type specifier corresponding to this type. |
---|
1348 | ;;; |
---|
1349 | (defun type-specifier (type) |
---|
1350 | (unless (ctype-p type) |
---|
1351 | (setq type (require-type type 'ctype))) |
---|
1352 | (locally |
---|
1353 | (declare (type ctype type)) |
---|
1354 | (funcall (type-class-unparse (ctype-class-info type)) type))) |
---|
1355 | |
---|
1356 | ;;; VALUES-SPECIFIER-TYPE -- Interface |
---|
1357 | ;;; |
---|
1358 | ;;; Return the type structure corresponding to a type specifier. We pick |
---|
1359 | ;;; off Structure types as a special case. |
---|
1360 | ;;; |
---|
1361 | |
---|
1362 | (defun values-specifier-type-internal (orig env) |
---|
1363 | (or (info-type-builtin orig) ; this table could contain bytes etal and ands ors nots of built-in types - no classes |
---|
1364 | |
---|
1365 | ;; Now that we have our hands on the environment, we could pass it into type-expand, |
---|
1366 | ;; but we'd have no way of knowing whether the expansion depended on the env, so |
---|
1367 | ;; we wouldn't know if the result is safe to cache. So for now don't let type |
---|
1368 | ;; expanders see the env, which just means they won't see compile-time types. |
---|
1369 | (let ((spec (type-expand orig #+not-yet env))) |
---|
1370 | (cond |
---|
1371 | ((and (not (eq spec orig)) |
---|
1372 | (info-type-builtin spec))) |
---|
1373 | ((or (eq (info-type-kind spec) :instance) |
---|
1374 | (and (symbolp spec) |
---|
1375 | (typep (find-class spec nil env) 'compile-time-class))) |
---|
1376 | (let* ((class-ctype (%class.ctype (find-class spec t env)))) |
---|
1377 | (or (class-ctype-translation class-ctype) |
---|
1378 | class-ctype))) |
---|
1379 | ((typep spec 'class) |
---|
1380 | (let* ((class-ctype (%class.ctype spec))) |
---|
1381 | (or (class-ctype-translation class-ctype) |
---|
1382 | class-ctype))) |
---|
1383 | ((let ((cell (find-builtin-cell spec nil))) |
---|
1384 | (and cell (cdr cell)))) |
---|
1385 | (t |
---|
1386 | (let* ((lspec (if (atom spec) (list spec) spec)) |
---|
1387 | (fun (info-type-translator (car lspec)))) |
---|
1388 | (cond (fun (funcall fun lspec env)) |
---|
1389 | ((or (and (consp spec) (symbolp (car spec))) |
---|
1390 | (symbolp spec)) |
---|
1391 | (when *type-system-initialized* |
---|
1392 | (signal 'parse-unknown-type :specifier spec)) |
---|
1393 | ;; |
---|
1394 | ;; Inhibit caching... |
---|
1395 | nil) |
---|
1396 | (t |
---|
1397 | (error "Bad thing to be a type specifier: ~S." spec))))))))) |
---|
1398 | |
---|
1399 | (eval-when (:compile-toplevel :execute) |
---|
1400 | (defconstant type-cache-size (ash 1 12)) |
---|
1401 | (defconstant type-cache-mask (1- type-cache-size))) |
---|
1402 | |
---|
1403 | (defun compile-time-ctype-p (ctype) |
---|
1404 | (and (typep ctype 'class-ctype) |
---|
1405 | (typep (class-ctype-class ctype) 'compile-time-class))) |
---|
1406 | |
---|
1407 | |
---|
1408 | ;;; We can get in trouble if we try to cache certain kinds of ctypes, |
---|
1409 | ;;; notably MEMBER types which refer to objects which might |
---|
1410 | ;;; be stack-allocated or might be EQUAL without being EQL. |
---|
1411 | (defun cacheable-ctype-p (ctype) |
---|
1412 | (case (istruct-cell-name (%svref ctype 0)) |
---|
1413 | (member-ctype |
---|
1414 | (dolist (m (member-ctype-members ctype) t) |
---|
1415 | (when (or (typep m 'cons) |
---|
1416 | (typep m 'array)) |
---|
1417 | (return nil)))) |
---|
1418 | (union-ctype |
---|
1419 | (every #'cacheable-ctype-p (union-ctype-types ctype))) |
---|
1420 | (intersection-ctype |
---|
1421 | (every #'cacheable-ctype-p (intersection-ctype-types ctype))) |
---|
1422 | (array-ctype |
---|
1423 | (cacheable-ctype-p (array-ctype-element-type ctype))) |
---|
1424 | ((values-ctype function-ctype) |
---|
1425 | (and (every #'cacheable-ctype-p (values-ctype-required ctype)) |
---|
1426 | (every #'cacheable-ctype-p (values-ctype-optional ctype)) |
---|
1427 | (let* ((rest (values-ctype-rest ctype))) |
---|
1428 | (or (null rest) (cacheable-ctype-p rest))) |
---|
1429 | (every #'(lambda (info) |
---|
1430 | (cacheable-ctype-p (key-info-type info))) |
---|
1431 | (values-ctype-keywords ctype)) |
---|
1432 | (or (not (eq (istruct-cell-name (%svref ctype 0)) 'function-ctype)) |
---|
1433 | (let* ((result (function-ctype-returns ctype))) |
---|
1434 | (or (null result) |
---|
1435 | (cacheable-ctype-p result)))))) |
---|
1436 | (negation-ctype |
---|
1437 | (cacheable-ctype-p (negation-ctype-type ctype))) |
---|
1438 | (cons-ctype |
---|
1439 | (and (cacheable-ctype-p (cons-ctype-car-ctype ctype)) |
---|
1440 | (cacheable-ctype-p (cons-ctype-cdr-ctype ctype)))) |
---|
1441 | (unknown-ctype nil) |
---|
1442 | (class-ctype |
---|
1443 | (not (typep (class-ctype-class ctype) 'compile-time-class))) |
---|
1444 | ;; Anything else ? Simple things (numbers, classes) can't lose. |
---|
1445 | (t t))) |
---|
1446 | |
---|
1447 | |
---|
1448 | |
---|
1449 | |
---|
1450 | (defun hash-type-specifier (spec) |
---|
1451 | (logand (sxhash spec) type-cache-mask)) |
---|
1452 | |
---|
1453 | (let* ((type-cache-specs (make-array type-cache-size)) |
---|
1454 | (type-cache-ctypes (make-array type-cache-size)) |
---|
1455 | (probes 0) |
---|
1456 | (hits 0) |
---|
1457 | (ncleared 0) |
---|
1458 | (locked nil)) |
---|
1459 | |
---|
1460 | (defun clear-type-cache () |
---|
1461 | (%init-misc 0 type-cache-specs) |
---|
1462 | (%init-misc 0 type-cache-ctypes) |
---|
1463 | (incf ncleared) |
---|
1464 | nil) |
---|
1465 | |
---|
1466 | (defun values-specifier-type (spec &optional env) |
---|
1467 | (if (typep spec 'class) |
---|
1468 | (let* ((class-ctype (%class.ctype spec))) |
---|
1469 | (or (class-ctype-translation class-ctype) class-ctype)) |
---|
1470 | (if locked |
---|
1471 | (or (values-specifier-type-internal spec env) |
---|
1472 | (make-unknown-ctype :specifier spec)) |
---|
1473 | (unwind-protect |
---|
1474 | (progn |
---|
1475 | (setq locked t) |
---|
1476 | (if (or (symbolp spec) |
---|
1477 | (and (consp spec) (symbolp (car spec)))) |
---|
1478 | (let* ((idx (hash-type-specifier spec))) |
---|
1479 | (incf probes) |
---|
1480 | (if (equal (svref type-cache-specs idx) spec) |
---|
1481 | (progn |
---|
1482 | (incf hits) |
---|
1483 | (svref type-cache-ctypes idx)) |
---|
1484 | (let* ((ctype (values-specifier-type-internal spec env))) |
---|
1485 | (if ctype |
---|
1486 | (progn |
---|
1487 | (when (cacheable-ctype-p ctype) |
---|
1488 | (setf (svref type-cache-specs idx) (copy-tree spec) ; in case it was stack-consed |
---|
1489 | (svref type-cache-ctypes idx) ctype)) |
---|
1490 | ctype) |
---|
1491 | (make-unknown-ctype :specifier spec))))) |
---|
1492 | (values-specifier-type-internal spec env))) |
---|
1493 | (setq locked nil))))) |
---|
1494 | |
---|
1495 | (defun type-cache-hit-rate () |
---|
1496 | (values hits probes)) |
---|
1497 | |
---|
1498 | (defun type-cache-locked-p () |
---|
1499 | locked) |
---|
1500 | |
---|
1501 | (defun lock-type-cache () |
---|
1502 | (setq locked t))) |
---|
1503 | |
---|
1504 | |
---|
1505 | |
---|
1506 | |
---|
1507 | |
---|
1508 | ;;; SPECIFIER-TYPE -- Interface |
---|
1509 | ;;; |
---|
1510 | ;;; Like VALUES-SPECIFIER-TYPE, except that we guarantee to never return a |
---|
1511 | ;;; VALUES type. |
---|
1512 | ;;; |
---|
1513 | (defun specifier-type (x &optional env) |
---|
1514 | (let ((res (values-specifier-type x env))) |
---|
1515 | (when (values-ctype-p res) |
---|
1516 | (signal-program-error "VALUES type illegal in this context:~% ~S" x)) |
---|
1517 | res)) |
---|
1518 | |
---|
1519 | (defun single-value-specifier-type (x &optional env) |
---|
1520 | (let ((res (specifier-type x env))) |
---|
1521 | (if (eq res *wild-type*) |
---|
1522 | *universal-type* |
---|
1523 | res))) |
---|
1524 | |
---|
1525 | (defun standardized-type-specifier (spec &optional env) |
---|
1526 | (handler-case |
---|
1527 | (type-specifier (specifier-type spec env)) |
---|
1528 | (parse-unknown-type () spec))) |
---|
1529 | |
---|
1530 | (defun modified-numeric-type (base |
---|
1531 | &key |
---|
1532 | (class (numeric-ctype-class base)) |
---|
1533 | (format (numeric-ctype-format base)) |
---|
1534 | (complexp (numeric-ctype-complexp base)) |
---|
1535 | (low (numeric-ctype-low base)) |
---|
1536 | (high (numeric-ctype-high base)) |
---|
1537 | (enumerable (ctype-enumerable base))) |
---|
1538 | (make-numeric-ctype :class class |
---|
1539 | :format format |
---|
1540 | :complexp complexp |
---|
1541 | :low low |
---|
1542 | :high high |
---|
1543 | :enumerable enumerable)) |
---|
1544 | |
---|
1545 | ;;; Precompute-Types -- Interface |
---|
1546 | ;;; |
---|
1547 | ;;; Take a list of type specifiers, compute the translation and define it as |
---|
1548 | ;;; a builtin type. |
---|
1549 | ;;; |
---|
1550 | |
---|
1551 | (defun precompute-types (specs) |
---|
1552 | (dolist (spec specs) |
---|
1553 | (let ((res (specifier-type spec))) |
---|
1554 | (when (numeric-ctype-p res) |
---|
1555 | (let ((pred (make-numeric-ctype-predicate res))) |
---|
1556 | (when pred (setf (numeric-ctype-predicate res) pred)))) |
---|
1557 | (unless (unknown-ctype-p res) |
---|
1558 | (setf (info-type-builtin spec) res) |
---|
1559 | (setf (info-type-kind spec) :primitive))))) |
---|
1560 | |
---|
1561 | ;;;; Builtin types. |
---|
1562 | |
---|
1563 | ;;; The NAMED-TYPE is used to represent *, T and NIL. These types must be |
---|
1564 | ;;; super or sub types of all types, not just classes and * & NIL aren't |
---|
1565 | ;;; classes anyway, so it wouldn't make much sense to make them built-in |
---|
1566 | ;;; classes. |
---|
1567 | ;;; |
---|
1568 | |
---|
1569 | (defun define-named-ctype (name) |
---|
1570 | (let* ((ctype (%istruct 'named-ctype |
---|
1571 | (type-class-or-lose 'named) |
---|
1572 | nil |
---|
1573 | name))) |
---|
1574 | (setf (info-type-kind name) :builtin |
---|
1575 | (info-type-builtin name) ctype))) |
---|
1576 | |
---|
1577 | |
---|
1578 | (defvar *wild-type* (define-named-ctype '*)) |
---|
1579 | (defvar *empty-type* (define-named-ctype nil)) |
---|
1580 | (defvar *universal-type* (define-named-ctype t)) |
---|
1581 | |
---|
1582 | (defun named-ctype-p (x) |
---|
1583 | (istruct-typep x 'named-ctype)) |
---|
1584 | |
---|
1585 | (setf (type-predicate 'named-ctype) 'named-ctype-p) |
---|
1586 | |
---|
1587 | (define-type-method (named :simple-=) (type1 type2) |
---|
1588 | (values (eq type1 type2) t)) |
---|
1589 | |
---|
1590 | (define-type-method (named :complex-=) (type1 type2) |
---|
1591 | (cond |
---|
1592 | ((and (eq type2 *empty-type*) |
---|
1593 | (intersection-ctype-p type1) |
---|
1594 | ;; not allowed to be unsure on these... FIXME: keep the list |
---|
1595 | ;; of CL types that are intersection types once and only |
---|
1596 | ;; once. |
---|
1597 | (not (or (type= type1 (specifier-type 'ratio)) |
---|
1598 | (type= type1 (specifier-type 'keyword))))) |
---|
1599 | ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION |
---|
1600 | ;; STREAM) can get here. In general, we can't really tell |
---|
1601 | ;; whether these are equal to NIL or not, so |
---|
1602 | (values nil nil)) |
---|
1603 | ((type-might-contain-other-types-p type1) |
---|
1604 | (invoke-complex-=-other-method type1 type2)) |
---|
1605 | (t (values nil t)))) |
---|
1606 | |
---|
1607 | |
---|
1608 | (define-type-method (named :simple-subtypep) (type1 type2) |
---|
1609 | (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t)) |
---|
1610 | |
---|
1611 | (define-type-method (named :complex-subtypep-arg1) (type1 type2) |
---|
1612 | (cond ((eq type1 *empty-type*) |
---|
1613 | t) |
---|
1614 | (;; When TYPE2 might be the universal type in disguise |
---|
1615 | (type-might-contain-other-types-p type2) |
---|
1616 | ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods |
---|
1617 | ;; can delegate to us (more or less as CALL-NEXT-METHOD) when |
---|
1618 | ;; they're uncertain, we can't just barf on COMPOUND-TYPE and |
---|
1619 | ;; HAIRY-TYPEs as we used to. Instead we deal with the |
---|
1620 | ;; problem (where at least part of the problem is cases like |
---|
1621 | ;; (SUBTYPEP T '(SATISFIES FOO)) |
---|
1622 | ;; or |
---|
1623 | ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))) |
---|
1624 | ;; where the second type is a hairy type like SATISFIES, or |
---|
1625 | ;; is a compound type which might contain a hairy type) by |
---|
1626 | ;; returning uncertainty. |
---|
1627 | (values nil nil)) |
---|
1628 | (t |
---|
1629 | ;; By elimination, TYPE1 is the universal type. |
---|
1630 | (assert (or (eq type1 *wild-type*) (eq type1 *universal-type*))) |
---|
1631 | ;; This case would have been picked off by the SIMPLE-SUBTYPEP |
---|
1632 | ;; method, and so shouldn't appear here. |
---|
1633 | (assert (not (eq type2 *universal-type*))) |
---|
1634 | ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not the |
---|
1635 | ;; universal type in disguise, TYPE2 is not a superset of TYPE1. |
---|
1636 | (values nil t)))) |
---|
1637 | |
---|
1638 | |
---|
1639 | (define-type-method (named :complex-subtypep-arg2) (type1 type2) |
---|
1640 | (assert (not (eq type2 *wild-type*))) ; * isn't really a type. |
---|
1641 | (cond ((eq type2 *universal-type*) |
---|
1642 | (values t t)) |
---|
1643 | ((type-might-contain-other-types-p type1) |
---|
1644 | ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in |
---|
1645 | ;; disguise. So we'd better delegate. |
---|
1646 | (invoke-complex-subtypep-arg1-method type1 type2)) |
---|
1647 | (t |
---|
1648 | ;; FIXME: This seems to rely on there only being 2 or 3 |
---|
1649 | ;; NAMED-TYPE values, and the exclusion of various |
---|
1650 | ;; possibilities above. It would be good to explain it and/or |
---|
1651 | ;; rewrite it so that it's clearer. |
---|
1652 | (values (not (eq type2 *empty-type*)) t)))) |
---|
1653 | |
---|
1654 | |
---|
1655 | (define-type-method (named :complex-intersection) (type1 type2) |
---|
1656 | (hierarchical-intersection2 type1 type2)) |
---|
1657 | |
---|
1658 | (define-type-method (named :unparse) (x) |
---|
1659 | (named-ctype-name x)) |
---|
1660 | |
---|
1661 | |
---|
1662 | ;;;; Hairy and unknown types: |
---|
1663 | |
---|
1664 | ;;; The Hairy-Type represents anything too wierd to be described |
---|
1665 | ;;; reasonably or to be useful, such as SATISFIES. We just remember |
---|
1666 | ;;; the original type spec. |
---|
1667 | ;;; |
---|
1668 | |
---|
1669 | (defun make-hairy-ctype (&key specifier (enumerable t)) |
---|
1670 | (%istruct 'hairy-ctype |
---|
1671 | (type-class-or-lose 'hairy) |
---|
1672 | enumerable |
---|
1673 | specifier)) |
---|
1674 | |
---|
1675 | (defun hairy-ctype-p (x) |
---|
1676 | (or (istruct-typep x 'hairy-ctype) |
---|
1677 | (istruct-typep x 'unknown-ctype))) |
---|
1678 | |
---|
1679 | (setf (type-predicate 'hairy-ctype) 'hairy-ctype-p) |
---|
1680 | |
---|
1681 | (define-type-method (hairy :unparse) (x) (hairy-ctype-specifier x)) |
---|
1682 | |
---|
1683 | (define-type-method (hairy :simple-subtypep) (type1 type2) |
---|
1684 | (let ((hairy-spec1 (hairy-ctype-specifier type1)) |
---|
1685 | (hairy-spec2 (hairy-ctype-specifier type2))) |
---|
1686 | (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2) |
---|
1687 | (values t t)) |
---|
1688 | (t |
---|
1689 | (values nil nil))))) |
---|
1690 | |
---|
1691 | (define-type-method (hairy :complex-subtypep-arg2) (type1 type2) |
---|
1692 | (invoke-complex-subtypep-arg1-method type1 type2)) |
---|
1693 | |
---|
1694 | (define-type-method (hairy :complex-subtypep-arg1) (type1 type2) |
---|
1695 | (declare (ignore type1 type2)) |
---|
1696 | (values nil nil)) |
---|
1697 | |
---|
1698 | (define-type-method (hairy :complex-=) (type1 type2) |
---|
1699 | (if (and (unknown-ctype-p type2) |
---|
1700 | (let* ((specifier2 (unknown-ctype-specifier type2)) |
---|
1701 | (name2 (if (consp specifier2) |
---|
1702 | (car specifier2) |
---|
1703 | specifier2))) |
---|
1704 | (info-type-kind name2))) |
---|
1705 | (let ((type2 (specifier-type (unknown-ctype-specifier type2)))) |
---|
1706 | (if (unknown-ctype-p type2) |
---|
1707 | (values nil nil) |
---|
1708 | (type= type1 type2))) |
---|
1709 | (values nil nil))) |
---|
1710 | |
---|
1711 | (define-type-method (hairy :simple-intersection :complex-intersection) |
---|
1712 | (type1 type2) |
---|
1713 | (if (type= type1 type2) |
---|
1714 | type1 |
---|
1715 | nil)) |
---|
1716 | |
---|
1717 | |
---|
1718 | (define-type-method (hairy :simple-union) |
---|
1719 | (type1 type2) |
---|
1720 | (if (type= type1 type2) |
---|
1721 | type1 |
---|
1722 | nil)) |
---|
1723 | |
---|
1724 | (define-type-method (hairy :simple-=) (type1 type2) |
---|
1725 | (if (equal-but-no-car-recursion (hairy-ctype-specifier type1) |
---|
1726 | (hairy-ctype-specifier type2)) |
---|
1727 | (values t t) |
---|
1728 | (values nil nil))) |
---|
1729 | |
---|
1730 | |
---|
1731 | |
---|
1732 | (def-type-translator satisfies (&whole x fun) |
---|
1733 | (unless (symbolp fun) |
---|
1734 | (report-bad-arg fun 'symbol)) |
---|
1735 | (make-hairy-ctype :specifier x)) |
---|
1736 | |
---|
1737 | |
---|
1738 | ;;; Negation Ctypes |
---|
1739 | (defun make-negation-ctype (&key type (enumerable t)) |
---|
1740 | (%istruct 'negation-ctype |
---|
1741 | (type-class-or-lose 'negation) |
---|
1742 | enumerable |
---|
1743 | type)) |
---|
1744 | |
---|
1745 | (defun negation-ctype-p (x) |
---|
1746 | (istruct-typep x 'negation-ctype)) |
---|
1747 | |
---|
1748 | (setf (type-predicate 'negation-ctype) 'negation-ctype-p) |
---|
1749 | |
---|
1750 | (define-type-method (negation :unparse) (x) |
---|
1751 | `(not ,(type-specifier (negation-ctype-type x)))) |
---|
1752 | |
---|
1753 | (define-type-method (negation :simple-subtypep) (type1 type2) |
---|
1754 | (csubtypep (negation-ctype-type type2) (negation-ctype-type type1))) |
---|
1755 | |
---|
1756 | (define-type-method (negation :complex-subtypep-arg2) (type1 type2) |
---|
1757 | (let* ((complement-type2 (negation-ctype-type type2)) |
---|
1758 | (intersection2 (type-intersection type1 complement-type2))) |
---|
1759 | (if intersection2 |
---|
1760 | ;; FIXME: if uncertain, maybe try arg1? |
---|
1761 | (type= intersection2 *empty-type*) |
---|
1762 | (invoke-complex-subtypep-arg1-method type1 type2)))) |
---|
1763 | |
---|
1764 | (define-type-method (negation :complex-subtypep-arg1) (type1 type2) |
---|
1765 | (block nil |
---|
1766 | ;; (Several logical truths in this block are true as long as |
---|
1767 | ;; b/=T. As of sbcl-0.7.1.28, it seems impossible to construct a |
---|
1768 | ;; case with b=T where we actually reach this type method, but |
---|
1769 | ;; we'll test for and exclude this case anyway, since future |
---|
1770 | ;; maintenance might make it possible for it to end up in this |
---|
1771 | ;; code.) |
---|
1772 | (multiple-value-bind (equal certain) |
---|
1773 | (type= type2 *universal-type*) |
---|
1774 | (unless certain |
---|
1775 | (return (values nil nil))) |
---|
1776 | (when equal |
---|
1777 | (return (values t t)))) |
---|
1778 | (let ((complement-type1 (negation-ctype-type type1))) |
---|
1779 | ;; Do the special cases first, in order to give us a chance if |
---|
1780 | ;; subtype/supertype relationships are hairy. |
---|
1781 | (multiple-value-bind (equal certain) |
---|
1782 | (type= complement-type1 type2) |
---|
1783 | ;; If a = b, ~a is not a subtype of b (unless b=T, which was |
---|
1784 | ;; excluded above). |
---|
1785 | (unless certain |
---|
1786 | (return (values nil nil))) |
---|
1787 | (when equal |
---|
1788 | (return (values nil t)))) |
---|
1789 | ;; KLUDGE: ANSI requires that the SUBTYPEP result between any |
---|
1790 | ;; two built-in atomic type specifiers never be uncertain. This |
---|
1791 | ;; is hard to do cleanly for the built-in types whose |
---|
1792 | ;; definitions include (NOT FOO), i.e. CONS and RATIO. However, |
---|
1793 | ;; we can do it with this hack, which uses our global knowledge |
---|
1794 | ;; that our implementation of the type system uses disjoint |
---|
1795 | ;; implementation types to represent disjoint sets (except when |
---|
1796 | ;; types are contained in other types). (This is a KLUDGE |
---|
1797 | ;; because it's fragile. Various changes in internal |
---|
1798 | ;; representation in the type system could make it start |
---|
1799 | ;; confidently returning incorrect results.) -- WHN 2002-03-08 |
---|
1800 | (unless (or (type-might-contain-other-types-p complement-type1) |
---|
1801 | (type-might-contain-other-types-p type2)) |
---|
1802 | ;; Because of the way our types which don't contain other |
---|
1803 | ;; types are disjoint subsets of the space of possible values, |
---|
1804 | ;; (SUBTYPEP '(NOT AA) 'B)=NIL when AA and B are simple (and B |
---|
1805 | ;; is not T, as checked above). |
---|
1806 | (return (values nil t))) |
---|
1807 | ;; The old (TYPE= TYPE1 TYPE2) branch would never be taken, as |
---|
1808 | ;; TYPE1 and TYPE2 will only be equal if they're both NOT types, |
---|
1809 | ;; and then the :SIMPLE-SUBTYPEP method would be used instead. |
---|
1810 | ;; But a CSUBTYPEP relationship might still hold: |
---|
1811 | (multiple-value-bind (equal certain) |
---|
1812 | (csubtypep complement-type1 type2) |
---|
1813 | ;; If a is a subtype of b, ~a is not a subtype of b (unless |
---|
1814 | ;; b=T, which was excluded above). |
---|
1815 | (unless certain |
---|
1816 | (return (values nil nil))) |
---|
1817 | (when equal |
---|
1818 | (return (values nil t)))) |
---|
1819 | (multiple-value-bind (equal certain) |
---|
1820 | (csubtypep type2 complement-type1) |
---|
1821 | ;; If b is a subtype of a, ~a is not a subtype of b. (FIXME: |
---|
1822 | ;; That's not true if a=T. Do we know at this point that a is |
---|
1823 | ;; not T?) |
---|
1824 | (unless certain |
---|
1825 | (return (values nil nil))) |
---|
1826 | (when equal |
---|
1827 | (return (values nil t)))) |
---|
1828 | ;; old CSR comment ca. 0.7.2, now obsoleted by the SIMPLE-CTYPE? |
---|
1829 | ;; KLUDGE case above: Other cases here would rely on being able |
---|
1830 | ;; to catch all possible cases, which the fragility of this type |
---|
1831 | ;; system doesn't inspire me; for instance, if a is type= to ~b, |
---|
1832 | ;; then we want T, T; if this is not the case and the types are |
---|
1833 | ;; disjoint (have an intersection of *empty-type*) then we want |
---|
1834 | ;; NIL, T; else if the union of a and b is the *universal-type* |
---|
1835 | ;; then we want T, T. So currently we still claim to be unsure |
---|
1836 | ;; about e.g. (subtypep '(not fixnum) 'single-float). |
---|
1837 | ;; |
---|
1838 | ;; OTOH we might still get here: |
---|
1839 | (values nil nil)))) |
---|
1840 | |
---|
1841 | (define-type-method (negation :complex-=) (type1 type2) |
---|
1842 | ;; (NOT FOO) isn't equivalent to anything that's not a negation |
---|
1843 | ;; type, except possibly a type that might contain it in disguise. |
---|
1844 | (declare (ignore type2)) |
---|
1845 | (if (type-might-contain-other-types-p type1) |
---|
1846 | (values nil nil) |
---|
1847 | (values nil t))) |
---|
1848 | |
---|
1849 | (define-type-method (negation :simple-intersection) (type1 type2) |
---|
1850 | (let ((not1 (negation-ctype-type type1)) |
---|
1851 | (not2 (negation-ctype-type type2))) |
---|
1852 | (cond |
---|
1853 | ((csubtypep not1 not2) type2) |
---|
1854 | ((csubtypep not2 not1) type1) |
---|
1855 | ;; Why no analagous clause to the disjoint in the SIMPLE-UNION2 |
---|
1856 | ;; method, below? The clause would read |
---|
1857 | ;; |
---|
1858 | ;; ((EQ (TYPE-UNION NOT1 NOT2) *UNIVERSAL-TYPE*) *EMPTY-TYPE*) |
---|
1859 | ;; |
---|
1860 | ;; but with proper canonicalization of negation types, there's |
---|
1861 | ;; no way of constructing two negation types with union of their |
---|
1862 | ;; negations being the universal type. |
---|
1863 | (t |
---|
1864 | nil)))) |
---|
1865 | |
---|
1866 | (define-type-method (negation :complex-intersection) (type1 type2) |
---|
1867 | (cond |
---|
1868 | ((csubtypep type1 (negation-ctype-type type2)) *empty-type*) |
---|
1869 | ((eq (type-intersection type1 (negation-ctype-type type2)) *empty-type*) |
---|
1870 | type1) |
---|
1871 | (t nil))) |
---|
1872 | |
---|
1873 | (define-type-method (negation :simple-union) (type1 type2) |
---|
1874 | (let ((not1 (negation-ctype-type type1)) |
---|
1875 | (not2 (negation-ctype-type type2))) |
---|
1876 | (cond |
---|
1877 | ((csubtypep not1 not2) type1) |
---|
1878 | ((csubtypep not2 not1) type2) |
---|
1879 | ((eq (type-intersection not1 not2) *empty-type*) |
---|
1880 | *universal-type*) |
---|
1881 | (t nil)))) |
---|
1882 | |
---|
1883 | (define-type-method (negation :complex-union) (type1 type2) |
---|
1884 | (cond |
---|
1885 | ((csubtypep (negation-ctype-type type2) type1) *universal-type*) |
---|
1886 | ((eq (type-intersection type1 (negation-ctype-type type2)) *empty-type*) |
---|
1887 | type2) |
---|
1888 | (t nil))) |
---|
1889 | |
---|
1890 | (define-type-method (negation :simple-=) (type1 type2) |
---|
1891 | (type= (negation-ctype-type type1) (negation-ctype-type type2))) |
---|
1892 | |
---|
1893 | (def-type-translator not (typespec &environment env) |
---|
1894 | (let* ((not-type (specifier-type typespec env)) |
---|
1895 | (spec (type-specifier not-type))) |
---|
1896 | (cond |
---|
1897 | ;; canonicalize (NOT (NOT FOO)) |
---|
1898 | ((and (listp spec) (eq (car spec) 'not)) |
---|
1899 | (specifier-type (cadr spec) env)) |
---|
1900 | ;; canonicalize (NOT NIL) and (NOT T) |
---|
1901 | ((eq not-type *empty-type*) *universal-type*) |
---|
1902 | ((eq not-type *universal-type*) *empty-type*) |
---|
1903 | ((and (numeric-ctype-p not-type) |
---|
1904 | (null (numeric-ctype-low not-type)) |
---|
1905 | (null (numeric-ctype-high not-type))) |
---|
1906 | (make-negation-ctype :type not-type)) |
---|
1907 | ((numeric-ctype-p not-type) |
---|
1908 | (type-union |
---|
1909 | (make-negation-ctype |
---|
1910 | :type (modified-numeric-type not-type :low nil :high nil)) |
---|
1911 | (cond |
---|
1912 | ((null (numeric-ctype-low not-type)) |
---|
1913 | (modified-numeric-type |
---|
1914 | not-type |
---|
1915 | :low (let ((h (numeric-ctype-high not-type))) |
---|
1916 | (if (consp h) (car h) (list h))) |
---|
1917 | :high nil)) |
---|
1918 | ((null (numeric-ctype-high not-type)) |
---|
1919 | (modified-numeric-type |
---|
1920 | not-type |
---|
1921 | :low nil |
---|
1922 | :high (let ((l (numeric-ctype-low not-type))) |
---|
1923 | (if (consp l) (car l) (list l))))) |
---|
1924 | (t (type-union |
---|
1925 | (modified-numeric-type |
---|
1926 | not-type |
---|
1927 | :low nil |
---|
1928 | :high (let ((l (numeric-ctype-low not-type))) |
---|
1929 | (if (consp l) (car l) (list l)))) |
---|
1930 | (modified-numeric-type |
---|
1931 | not-type |
---|
1932 | :low (let ((h (numeric-ctype-high not-type))) |
---|
1933 | (if (consp h) (car h) (list h))) |
---|
1934 | :high nil)))))) |
---|
1935 | ((intersection-ctype-p not-type) |
---|
1936 | (apply #'type-union |
---|
1937 | (mapcar #'(lambda (x) |
---|
1938 | (specifier-type `(not ,(type-specifier x)) env)) |
---|
1939 | (intersection-ctype-types not-type)))) |
---|
1940 | ((union-ctype-p not-type) |
---|
1941 | (apply #'type-intersection |
---|
1942 | (mapcar #'(lambda (x) |
---|
1943 | (specifier-type `(not ,(type-specifier x)) env)) |
---|
1944 | (union-ctype-types not-type)))) |
---|
1945 | ((member-ctype-p not-type) |
---|
1946 | (let ((members (member-ctype-members not-type))) |
---|
1947 | (if (some #'floatp members) |
---|
1948 | (let (floats) |
---|
1949 | (dolist (pair '((0.0f0 . -0.0f0) (0.0d0 . -0.0d0))) |
---|
1950 | (when (member (car pair) members) |
---|
1951 | (assert (not (member (cdr pair) members))) |
---|
1952 | (push (cdr pair) floats) |
---|
1953 | (setf members (remove (car pair) members))) |
---|
1954 | (when (member (cdr pair) members) |
---|
1955 | (assert (not (member (car pair) members))) |
---|
1956 | (push (car pair) floats) |
---|
1957 | (setf members (remove (cdr pair) members)))) |
---|
1958 | (apply #'type-intersection |
---|
1959 | (if (null members) |
---|
1960 | *universal-type* |
---|
1961 | (make-negation-ctype |
---|
1962 | :type (make-member-ctype :members members))) |
---|
1963 | (mapcar |
---|
1964 | (lambda (x) |
---|
1965 | (let ((type (ctype-of x))) |
---|
1966 | (type-union |
---|
1967 | (make-negation-ctype |
---|
1968 | :type (modified-numeric-type type |
---|
1969 | :low nil :high nil)) |
---|
1970 | (modified-numeric-type type |
---|
1971 | :low nil :high (list x)) |
---|
1972 | (make-member-ctype :members (list x)) |
---|
1973 | (modified-numeric-type type |
---|
1974 | :low (list x) :high nil)))) |
---|
1975 | floats))) |
---|
1976 | (make-negation-ctype :type not-type)))) |
---|
1977 | ((and (cons-ctype-p not-type) |
---|
1978 | (eq (cons-ctype-car-ctype not-type) *universal-type*) |
---|
1979 | (eq (cons-ctype-cdr-ctype not-type) *universal-type*)) |
---|
1980 | (make-negation-ctype :type not-type)) |
---|
1981 | ((cons-ctype-p not-type) |
---|
1982 | (type-union |
---|
1983 | (make-negation-ctype :type (specifier-type 'cons env)) |
---|
1984 | (cond |
---|
1985 | ((and (not (eq (cons-ctype-car-ctype not-type) *universal-type*)) |
---|
1986 | (not (eq (cons-ctype-cdr-ctype not-type) *universal-type*))) |
---|
1987 | (type-union |
---|
1988 | (make-cons-ctype |
---|
1989 | (specifier-type `(not ,(type-specifier |
---|
1990 | (cons-ctype-car-ctype not-type))) env) |
---|
1991 | *universal-type*) |
---|
1992 | (make-cons-ctype |
---|
1993 | *universal-type* |
---|
1994 | (specifier-type `(not ,(type-specifier |
---|
1995 | (cons-ctype-cdr-ctype not-type))) env)))) |
---|
1996 | ((not (eq (cons-ctype-car-ctype not-type) *universal-type*)) |
---|
1997 | (make-cons-ctype |
---|
1998 | (specifier-type `(not ,(type-specifier |
---|
1999 | (cons-ctype-car-ctype not-type))) env) |
---|
2000 | *universal-type*)) |
---|
2001 | ((not (eq (cons-ctype-cdr-ctype not-type) *universal-type*)) |
---|
2002 | (make-cons-ctype |
---|
2003 | *universal-type* |
---|
2004 | (specifier-type `(not ,(type-specifier |
---|
2005 | (cons-ctype-cdr-ctype not-type))) env))) |
---|
2006 | (t (error "Weird CONS type ~S" not-type))))) |
---|
2007 | (t (make-negation-ctype :type not-type))))) |
---|
2008 | |
---|
2009 | |
---|
2010 | ;;;; Numeric types. |
---|
2011 | |
---|
2012 | ;;; A list of all the float formats, in order of decreasing precision. |
---|
2013 | ;;; |
---|
2014 | (eval-when (:compile-toplevel :load-toplevel :execute) |
---|
2015 | (defconstant float-formats |
---|
2016 | '(long-float double-float single-float short-float))) |
---|
2017 | |
---|
2018 | ;;; The type of a float format. |
---|
2019 | ;;; |
---|
2020 | (deftype float-format () `(member ,@float-formats)) |
---|
2021 | |
---|
2022 | (defun type-bound-number (x) |
---|
2023 | (if (consp x) |
---|
2024 | (destructuring-bind (result) x result) |
---|
2025 | x)) |
---|
2026 | |
---|
2027 | (defun make-numeric-ctype (&key class |
---|
2028 | format |
---|
2029 | (complexp :real) |
---|
2030 | low |
---|
2031 | high |
---|
2032 | enumerable |
---|
2033 | predicate) |
---|
2034 | ;; if interval is empty |
---|
2035 | (if (and low |
---|
2036 | high |
---|
2037 | (if (or (consp low) (consp high)) ; if either bound is exclusive |
---|
2038 | (>= (type-bound-number low) (type-bound-number high)) |
---|
2039 | (> low high))) |
---|
2040 | *empty-type* |
---|
2041 | (multiple-value-bind (canonical-low canonical-high) |
---|
2042 | (case class |
---|
2043 | (integer |
---|
2044 | ;; INTEGER types always have their LOW and HIGH bounds |
---|
2045 | ;; represented as inclusive, not exclusive values. |
---|
2046 | (values (if (consp low) |
---|
2047 | (1+ (type-bound-number low)) |
---|
2048 | low) |
---|
2049 | (if (consp high) |
---|
2050 | (1- (type-bound-number high)) |
---|
2051 | high))) |
---|
2052 | (t |
---|
2053 | ;; no canonicalization necessary |
---|
2054 | (values low high))) |
---|
2055 | (when (and (eq class 'rational) |
---|
2056 | (integerp canonical-low) |
---|
2057 | (integerp canonical-high) |
---|
2058 | (= canonical-low canonical-high)) |
---|
2059 | (setf class 'integer)) |
---|
2060 | (%istruct 'numeric-ctype |
---|
2061 | (type-class-or-lose 'number) |
---|
2062 | enumerable |
---|
2063 | class |
---|
2064 | format |
---|
2065 | complexp |
---|
2066 | canonical-low |
---|
2067 | canonical-high |
---|
2068 | predicate)))) |
---|
2069 | |
---|
2070 | |
---|
2071 | (defun make-numeric-ctype-predicate (ctype) |
---|
2072 | (let ((class (numeric-ctype-class ctype)) |
---|
2073 | (lo (numeric-ctype-low ctype)) |
---|
2074 | (hi (numeric-ctype-high ctype))) |
---|
2075 | (if (eq class 'integer) |
---|
2076 | (if (and hi |
---|
2077 | lo |
---|
2078 | (<= hi target::target-most-positive-fixnum) |
---|
2079 | (>= lo target::target-most-negative-fixnum)) |
---|
2080 | #'(lambda (n) |
---|
2081 | (and (fixnump n) |
---|
2082 | (locally (declare (fixnum n hi lo)) |
---|
2083 | (and (%i>= n lo) |
---|
2084 | (%i<= n hi))))))))) |
---|
2085 | |
---|
2086 | (defun numeric-ctype-p (x) |
---|
2087 | (istruct-typep x 'numeric-ctype)) |
---|
2088 | |
---|
2089 | (setf (type-predicate 'numeric-ctype) 'numeric-ctype-p) |
---|
2090 | |
---|
2091 | (define-type-method (number :simple-=) (type1 type2) |
---|
2092 | (values |
---|
2093 | (and (eq (numeric-ctype-class type1) (numeric-ctype-class type2)) |
---|
2094 | (eq (numeric-ctype-format type1) (numeric-ctype-format type2)) |
---|
2095 | (eq (numeric-ctype-complexp type1) (numeric-ctype-complexp type2)) |
---|
2096 | (equalp (numeric-ctype-low type1) (numeric-ctype-low type2)) |
---|
2097 | (equalp (numeric-ctype-high type1) (numeric-ctype-high type2))) |
---|
2098 | t)) |
---|
2099 | |
---|
2100 | (define-type-method (number :unparse) (type) |
---|
2101 | (let* ((complexp (numeric-ctype-complexp type)) |
---|
2102 | (low (numeric-ctype-low type)) |
---|
2103 | (high (numeric-ctype-high type)) |
---|
2104 | (base (case (numeric-ctype-class type) |
---|
2105 | (integer 'integer) |
---|
2106 | (rational 'rational) |
---|
2107 | (float (or (numeric-ctype-format type) 'float)) |
---|
2108 | (t 'real)))) |
---|
2109 | (let ((base+bounds |
---|
2110 | (cond ((and (eq base 'integer) high low) |
---|
2111 | (let ((high-count (logcount high)) |
---|
2112 | (high-length (integer-length high))) |
---|
2113 | (cond ((= low 0) |
---|
2114 | (cond ((= high 0) '(integer 0 0)) |
---|
2115 | ((= high 1) 'bit) |
---|
2116 | ((and (= high-count high-length) |
---|
2117 | (plusp high-length)) |
---|
2118 | `(unsigned-byte ,high-length)) |
---|
2119 | (t |
---|
2120 | `(mod ,(1+ high))))) |
---|
2121 | ((and (= low target::target-most-negative-fixnum) |
---|
2122 | (= high target::target-most-positive-fixnum)) |
---|
2123 | 'fixnum) |
---|
2124 | ((and (= low (lognot high)) |
---|
2125 | (= high-count high-length) |
---|
2126 | (> high-count 0)) |
---|
2127 | `(signed-byte ,(1+ high-length))) |
---|
2128 | (t |
---|
2129 | `(integer ,low ,high))))) |
---|
2130 | (high `(,base ,(or low '*) ,high)) |
---|
2131 | (low |
---|
2132 | (if (and (eq base 'integer) (= low 0)) |
---|
2133 | 'unsigned-byte |
---|
2134 | `(,base ,low))) |
---|
2135 | (t base)))) |
---|
2136 | (ecase complexp |
---|
2137 | (:real |
---|
2138 | base+bounds) |
---|
2139 | (:complex |
---|
2140 | (if (eq base+bounds 'real) |
---|
2141 | 'complex |
---|
2142 | `(complex ,base+bounds))) |
---|
2143 | ((nil) |
---|
2144 | (assert (eq base+bounds 'real)) |
---|
2145 | 'number))))) |
---|
2146 | |
---|
2147 | ;;; Numeric-Bound-Test -- Internal |
---|
2148 | ;;; |
---|
2149 | ;;; Return true if X is "less than or equal" to Y, taking open bounds into |
---|
2150 | ;;; consideration. Closed is the predicate used to test the bound on a closed |
---|
2151 | ;;; interval (e.g. <=), and Open is the predicate used on open bounds (e.g. <). |
---|
2152 | ;;; Y is considered to be the outside bound, in the sense that if it is |
---|
2153 | ;;; infinite (NIL), then the test suceeds, whereas if X is infinite, then the |
---|
2154 | ;;; test fails (unless Y is also infinite). |
---|
2155 | ;;; |
---|
2156 | ;;; This is for comparing bounds of the same kind, e.g. upper and upper. |
---|
2157 | ;;; Use Numeric-Bound-Test* for different kinds of bounds. |
---|
2158 | ;;; |
---|
2159 | (defmacro numeric-bound-test (x y closed open) |
---|
2160 | `(cond ((not ,y) t) |
---|
2161 | ((not ,x) nil) |
---|
2162 | ((consp ,x) |
---|
2163 | (if (consp ,y) |
---|
2164 | (,closed (car ,x) (car ,y)) |
---|
2165 | (,closed (car ,x) ,y))) |
---|
2166 | (t |
---|
2167 | (if (consp ,y) |
---|
2168 | (,open ,x (car ,y)) |
---|
2169 | (,closed ,x ,y))))) |
---|
2170 | |
---|
2171 | ;;; Numeric-Bound-Test* -- Internal |
---|
2172 | ;;; |
---|
2173 | ;;; Used to compare upper and lower bounds. This is different from the |
---|
2174 | ;;; same-bound case: |
---|
2175 | ;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we return true |
---|
2176 | ;;; if *either* arg is NIL. |
---|
2177 | ;;; -- an open inner bound is "greater" and also squeezes the interval, causing |
---|
2178 | ;;; us to use the Open test for those cases as well. |
---|
2179 | ;;; |
---|
2180 | (defmacro numeric-bound-test* (x y closed open) |
---|
2181 | `(cond ((not ,y) t) |
---|
2182 | ((not ,x) t) |
---|
2183 | ((consp ,x) |
---|
2184 | (if (consp ,y) |
---|
2185 | (,open (car ,x) (car ,y)) |
---|
2186 | (,open (car ,x) ,y))) |
---|
2187 | (t |
---|
2188 | (if (consp ,y) |
---|
2189 | (,open ,x (car ,y)) |
---|
2190 | (,closed ,x ,y))))) |
---|
2191 | |
---|
2192 | ;;; Numeric-Bound-Max -- Internal |
---|
2193 | ;;; |
---|
2194 | ;;; Return whichever of the numeric bounds X and Y is "maximal" according to |
---|
2195 | ;;; the predicates Closed (e.g. >=) and Open (e.g. >). This is only meaningful |
---|
2196 | ;;; for maximizing like bounds, i.e. upper and upper. If Max-P is true, then |
---|
2197 | ;;; we return NIL if X or Y is NIL, otherwise we return the other arg. |
---|
2198 | ;;; |
---|
2199 | (defmacro numeric-bound-max (x y closed open max-p) |
---|
2200 | (once-only ((n-x x) |
---|
2201 | (n-y y)) |
---|
2202 | `(cond |
---|
2203 | ((not ,n-x) ,(if max-p nil n-y)) |
---|
2204 | ((not ,n-y) ,(if max-p nil n-x)) |
---|
2205 | ((consp ,n-x) |
---|
2206 | (if (consp ,n-y) |
---|
2207 | (if (,closed (car ,n-x) (car ,n-y)) ,n-x ,n-y) |
---|
2208 | (if (,open (car ,n-x) ,n-y) ,n-x ,n-y))) |
---|
2209 | (t |
---|
2210 | (if (consp ,n-y) |
---|
2211 | (if (,open (car ,n-y) ,n-x) ,n-y ,n-x) |
---|
2212 | (if (,closed ,n-y ,n-x) ,n-y ,n-x)))))) |
---|
2213 | |
---|
2214 | |
---|
2215 | (define-type-method (number :simple-subtypep) (type1 type2) |
---|
2216 | (let ((class1 (numeric-ctype-class type1)) |
---|
2217 | (class2 (numeric-ctype-class type2)) |
---|
2218 | (complexp2 (numeric-ctype-complexp type2)) |
---|
2219 | (format2 (numeric-ctype-format type2)) |
---|
2220 | (low1 (numeric-ctype-low type1)) |
---|
2221 | (high1 (numeric-ctype-high type1)) |
---|
2222 | (low2 (numeric-ctype-low type2)) |
---|
2223 | (high2 (numeric-ctype-high type2))) |
---|
2224 | ;; |
---|
2225 | ;; If one is complex and the other isn't, they are disjoint. |
---|
2226 | (cond ((not (or (eq (numeric-ctype-complexp type1) complexp2) |
---|
2227 | (null complexp2))) |
---|
2228 | (values nil t)) |
---|
2229 | ;; |
---|
2230 | ;; If the classes are specified and different, the types are |
---|
2231 | ;; disjoint unless type2 is rational and type1 is integer. |
---|
2232 | ((not (or (eq class1 class2) (null class2) |
---|
2233 | (and (eq class1 'integer) (eq class2 'rational)))) |
---|
2234 | (values nil t)) |
---|
2235 | ;; |
---|
2236 | ;; If the float formats are specified and different, the types |
---|
2237 | ;; are disjoint. |
---|
2238 | ((not (or (eq (numeric-ctype-format type1) format2) |
---|
2239 | (null format2))) |
---|
2240 | (values nil t)) |
---|
2241 | ;; |
---|
2242 | ;; Check the bounds. |
---|
2243 | ((and (numeric-bound-test low1 low2 >= >) |
---|
2244 | (numeric-bound-test high1 high2 <= <)) |
---|
2245 | (values t t)) |
---|
2246 | (t |
---|
2247 | (values nil t))))) |
---|
2248 | |
---|
2249 | ;(define-superclasses number (generic-number)) |
---|
2250 | |
---|
2251 | ;;; NUMERIC-TYPES-ADJACENT -- Internal |
---|
2252 | ;;; |
---|
2253 | ;;; If the high bound of Low is adjacent to the low bound of High, then |
---|
2254 | ;;; return T, otherwise NIL. |
---|
2255 | ;;; |
---|
2256 | (defun numeric-types-adjacent (low high) |
---|
2257 | (let ((low-bound (numeric-ctype-high low)) |
---|
2258 | (high-bound (numeric-ctype-low high))) |
---|
2259 | (cond ((not (and low-bound high-bound)) nil) |
---|
2260 | ((consp low-bound) |
---|
2261 | (eql (car low-bound) high-bound)) |
---|
2262 | ((consp high-bound) |
---|
2263 | (eql (car high-bound) low-bound)) |
---|
2264 | ((and (eq (numeric-ctype-class low) 'integer) |
---|
2265 | (eq (numeric-ctype-class high) 'integer)) |
---|
2266 | (eql (1+ low-bound) high-bound)) |
---|
2267 | (t |
---|
2268 | nil)))) |
---|
2269 | |
---|
2270 | ;;; |
---|
2271 | ;;; Return a numeric type that is a supertype for both type1 and type2. |
---|
2272 | ;;; |
---|
2273 | (define-type-method (number :simple-union) (type1 type2) |
---|
2274 | (declare (type numeric-ctype type1 type2)) |
---|
2275 | (cond ((csubtypep type1 type2) type2) |
---|
2276 | ((csubtypep type2 type1) type1) |
---|
2277 | (t |
---|
2278 | (let ((class1 (numeric-ctype-class type1)) |
---|
2279 | (format1 (numeric-ctype-format type1)) |
---|
2280 | (complexp1 (numeric-ctype-complexp type1)) |
---|
2281 | (class2 (numeric-ctype-class type2)) |
---|
2282 | (format2 (numeric-ctype-format type2)) |
---|
2283 | (complexp2 (numeric-ctype-complexp type2))) |
---|
2284 | (cond |
---|
2285 | ((and (eq class1 class2) |
---|
2286 | (eq format1 format2) |
---|
2287 | (eq complexp1 complexp2) |
---|
2288 | (or (numeric-types-intersect type1 type2) |
---|
2289 | (numeric-types-adjacent type1 type2) |
---|
2290 | (numeric-types-adjacent type2 type1))) |
---|
2291 | (make-numeric-ctype |
---|
2292 | :class class1 |
---|
2293 | :format format1 |
---|
2294 | :complexp complexp1 |
---|
2295 | :low (numeric-bound-max (numeric-ctype-low type1) |
---|
2296 | (numeric-ctype-low type2) |
---|
2297 | <= < t) |
---|
2298 | :high (numeric-bound-max (numeric-ctype-high type1) |
---|
2299 | (numeric-ctype-high type2) |
---|
2300 | >= > t))) |
---|
2301 | ;; FIXME: These two clauses are almost identical, and the |
---|
2302 | ;; consequents are in fact identical in every respect. |
---|
2303 | ((and (eq class1 'rational) |
---|
2304 | (eq class2 'integer) |
---|
2305 | (eq format1 format2) |
---|
2306 | (eq complexp1 complexp2) |
---|
2307 | (integerp (numeric-ctype-low type2)) |
---|
2308 | (integerp (numeric-ctype-high type2)) |
---|
2309 | (= (numeric-ctype-low type2) (numeric-ctype-high type2)) |
---|
2310 | (or (numeric-types-adjacent type1 type2) |
---|
2311 | (numeric-types-adjacent type2 type1))) |
---|
2312 | (make-numeric-ctype |
---|
2313 | :class 'rational |
---|
2314 | :format format1 |
---|
2315 | :complexp complexp1 |
---|
2316 | :low (numeric-bound-max (numeric-ctype-low type1) |
---|
2317 | (numeric-ctype-low type2) |
---|
2318 | <= < t) |
---|
2319 | :high (numeric-bound-max (numeric-ctype-high type1) |
---|
2320 | (numeric-ctype-high type2) |
---|
2321 | >= > t))) |
---|
2322 | ((and (eq class1 'integer) |
---|
2323 | (eq class2 'rational) |
---|
2324 | (eq format1 format2) |
---|
2325 | (eq complexp1 complexp2) |
---|
2326 | (integerp (numeric-ctype-low type1)) |
---|
2327 | (integerp (numeric-ctype-high type1)) |
---|
2328 | (= (numeric-ctype-low type1) (numeric-ctype-high type1)) |
---|
2329 | (or (numeric-types-adjacent type1 type2) |
---|
2330 | (numeric-types-adjacent type2 type1))) |
---|
2331 | (make-numeric-ctype |
---|
2332 | :class 'rational |
---|
2333 | :format format1 |
---|
2334 | :complexp complexp1 |
---|
2335 | :low (numeric-bound-max (numeric-ctype-low type1) |
---|
2336 | (numeric-ctype-low type2) |
---|
2337 | <= < t) |
---|
2338 | :high (numeric-bound-max (numeric-ctype-high type1) |
---|
2339 | (numeric-ctype-high type2) |
---|
2340 | >= > t))) |
---|
2341 | (t nil)))))) |
---|
2342 | |
---|
2343 | (setf (info-type-kind 'number) :primitive |
---|
2344 | (info-type-builtin 'number) (make-numeric-ctype :complexp nil)) |
---|
2345 | |
---|
2346 | (def-type-translator complex (&optional spec &environment env) |
---|
2347 | (if (eq spec '*) |
---|
2348 | (make-numeric-ctype :complexp :complex) |
---|
2349 | (labels ((not-numeric () |
---|
2350 | (error "Component type for Complex is not numeric: ~S." spec)) |
---|
2351 | (not-real () |
---|
2352 | (error "Component type for Complex is not a subtype of real: ~S." spec)) |
---|
2353 | (complex1 (component-type) |
---|
2354 | (unless (numeric-ctype-p component-type) |
---|
2355 | (not-numeric)) |
---|
2356 | (when (eq (numeric-ctype-complexp component-type) :complex) |
---|
2357 | (not-real)) |
---|
2358 | (let ((res (copy-uvector component-type))) |
---|
2359 | (setf (numeric-ctype-complexp res) :complex) |
---|
2360 | (setf (numeric-ctype-predicate res) nil) ; << |
---|
2361 | res)) |
---|
2362 | (do-complex (ctype) |
---|
2363 | (cond |
---|
2364 | ((eq ctype *empty-type*) *empty-type*) |
---|
2365 | ((eq ctype *universal-type*) (not-real)) |
---|
2366 | ((numeric-ctype-p ctype) (complex1 ctype)) |
---|
2367 | ((union-ctype-p ctype) |
---|
2368 | (apply #'type-union |
---|
2369 | (mapcar #'do-complex (union-ctype-types ctype)))) |
---|
2370 | ((member-ctype-p ctype) |
---|
2371 | (apply #'type-union |
---|
2372 | (mapcar (lambda (x) (do-complex (ctype-of x))) |
---|
2373 | (member-ctype-members ctype)))) |
---|
2374 | ((and (intersection-ctype-p ctype) |
---|
2375 | ;; just enough to handle simple types like RATIO. |
---|
2376 | (let ((numbers (remove-if-not |
---|
2377 | #'numeric-ctype-p |
---|
2378 | (intersection-ctype-types ctype)))) |
---|
2379 | (and (car numbers) |
---|
2380 | (null (cdr numbers)) |
---|
2381 | (eq (numeric-ctype-complexp (car numbers)) :real) |
---|
2382 | (complex1 (car numbers)))))) |
---|
2383 | (t ; punt on harder stuff for now |
---|
2384 | (not-real))))) |
---|
2385 | (let ((ctype (specifier-type spec env))) |
---|
2386 | (do-complex ctype))))) |
---|
2387 | |
---|
2388 | ;;; Check-Bound -- Internal |
---|
2389 | ;;; |
---|
2390 | ;;; Check that X is a well-formed numeric bound of the specified Type. |
---|
2391 | ;;; If X is *, return NIL, otherwise return the bound. |
---|
2392 | ;;; |
---|
2393 | (defmacro check-bound (x type) |
---|
2394 | `(cond ((eq ,x '*) nil) |
---|
2395 | ((or (typep ,x ',type) |
---|
2396 | (and (consp ,x) (typep (car ,x) ',type) (null (cdr ,x)))) |
---|
2397 | ,x) |
---|
2398 | (t |
---|
2399 | (error "Bound is not *, a ~A or a list of a ~A: ~S" ',type ',type ,x)))) |
---|
2400 | |
---|
2401 | (def-type-translator integer (&optional low high) |
---|
2402 | (let* ((l (check-bound low integer)) |
---|
2403 | (lb (if (consp l) (1+ (car l)) l)) |
---|
2404 | (h (check-bound high integer)) |
---|
2405 | (hb (if (consp h) (1- (car h)) h))) |
---|
2406 | (if (and hb lb (< hb lb)) |
---|
2407 | *empty-type* |
---|
2408 | (make-numeric-ctype :class 'integer :complexp :real |
---|
2409 | :enumerable (not (null (and l h))) |
---|
2410 | :low lb |
---|
2411 | :high hb)))) |
---|
2412 | |
---|
2413 | (deftype mod (n) |
---|
2414 | (unless (and (integerp n) (> n 0)) |
---|
2415 | (error "Bad N specified for MOD type specifier: ~S." n)) |
---|
2416 | `(integer 0 ,(1- n))) |
---|
2417 | |
---|
2418 | |
---|
2419 | (defmacro def-bounded-type (type class format) |
---|
2420 | `(def-type-translator ,type (&optional low high) |
---|
2421 | (let ((lb (check-bound low ,type)) |
---|
2422 | (hb (check-bound high ,type))) |
---|
2423 | (unless (numeric-bound-test* lb hb <= <) |
---|
2424 | (error "Lower bound ~S is not less than upper bound ~S." low high)) |
---|
2425 | (make-numeric-ctype :class ',class :format ',format :low lb :high hb)))) |
---|
2426 | |
---|
2427 | (def-bounded-type rational rational nil) |
---|
2428 | |
---|
2429 | (defun coerce-bound (bound type inner-coerce-bound-fun) |
---|
2430 | (declare (type function inner-coerce-bound-fun)) |
---|
2431 | (cond ((eql bound '*) |
---|
2432 | bound) |
---|
2433 | ((consp bound) |
---|
2434 | (destructuring-bind (inner-bound) bound |
---|
2435 | (list (funcall inner-coerce-bound-fun inner-bound type)))) |
---|
2436 | (t |
---|
2437 | (funcall inner-coerce-bound-fun bound type)))) |
---|
2438 | |
---|
2439 | (defun inner-coerce-real-bound (bound type) |
---|
2440 | (ecase type |
---|
2441 | (rational (rationalize bound)) |
---|
2442 | (float (if (floatp bound) |
---|
2443 | bound |
---|
2444 | ;; Coerce to the widest float format available, to |
---|
2445 | ;; avoid unnecessary loss of precision: |
---|
2446 | (coerce bound 'long-float))))) |
---|
2447 | |
---|
2448 | (defun coerced-real-bound (bound type) |
---|
2449 | (coerce-bound bound type #'inner-coerce-real-bound)) |
---|
2450 | |
---|
2451 | (defun coerced-float-bound (bound type) |
---|
2452 | (coerce-bound bound type #'coerce)) |
---|
2453 | |
---|
2454 | (def-type-translator real (&optional (low '*) (high '*)) |
---|
2455 | (specifier-type `(or (float ,(coerced-real-bound low 'float) |
---|
2456 | ,(coerced-real-bound high 'float)) |
---|
2457 | (rational ,(coerced-real-bound low 'rational) |
---|
2458 | ,(coerced-real-bound high 'rational))))) |
---|
2459 | |
---|
2460 | (def-type-translator float (&optional (low '*) (high '*)) |
---|
2461 | (specifier-type |
---|
2462 | `(or (single-float ,(coerced-float-bound low 'single-float) |
---|
2463 | ,(coerced-float-bound high 'single-float)) |
---|
2464 | (double-float ,(coerced-float-bound low 'double-float) |
---|
2465 | ,(coerced-float-bound high 'double-float))))) |
---|
2466 | |
---|
2467 | (def-bounded-type float float nil) |
---|
2468 | (def-bounded-type real nil nil) |
---|
2469 | |
---|
2470 | (defmacro define-float-format (f) |
---|
2471 | `(def-bounded-type ,f float ,f)) |
---|
2472 | |
---|
2473 | (define-float-format short-float) |
---|
2474 | (define-float-format single-float) |
---|
2475 | (define-float-format double-float) |
---|
2476 | (define-float-format long-float) |
---|
2477 | |
---|
2478 | (defun numeric-types-intersect (type1 type2) |
---|
2479 | (declare (type numeric-ctype type1 type2)) |
---|
2480 | (let* ((class1 (numeric-ctype-class type1)) |
---|
2481 | (class2 (numeric-ctype-class type2)) |
---|
2482 | (complexp1 (numeric-ctype-complexp type1)) |
---|
2483 | (complexp2 (numeric-ctype-complexp type2)) |
---|
2484 | (format1 (numeric-ctype-format type1)) |
---|
2485 | (format2 (numeric-ctype-format type2)) |
---|
2486 | (low1 (numeric-ctype-low type1)) |
---|
2487 | (high1 (numeric-ctype-high type1)) |
---|
2488 | (low2 (numeric-ctype-low type2)) |
---|
2489 | (high2 (numeric-ctype-high type2))) |
---|
2490 | ;; |
---|
2491 | ;; If one is complex and the other isn't, then they are disjoint. |
---|
2492 | (cond ((not (or (eq complexp1 complexp2) |
---|
2493 | (null complexp1) (null complexp2))) |
---|
2494 | nil) |
---|
2495 | ;; |
---|
2496 | ;; If either type is a float, then the other must either be specified |
---|
2497 | ;; to be a float or unspecified. Otherwise, they are disjoint. |
---|
2498 | ((and (eq class1 'float) (not (member class2 '(float nil)))) nil) |
---|
2499 | ((and (eq class2 'float) (not (member class1 '(float nil)))) nil) |
---|
2500 | ;; |
---|
2501 | ;; If the float formats are specified and different, the types |
---|
2502 | ;; are disjoint. |
---|
2503 | ((not (or (eq format1 format2) (null format1) (null format2))) |
---|
2504 | nil) |
---|
2505 | (t |
---|
2506 | ;; |
---|
2507 | ;; Check the bounds. This is a bit odd because we must always have |
---|
2508 | ;; the outer bound of the interval as the second arg. |
---|
2509 | (if (numeric-bound-test high1 high2 <= <) |
---|
2510 | (or (and (numeric-bound-test low1 low2 >= >) |
---|
2511 | (numeric-bound-test* low1 high2 <= <)) |
---|
2512 | (and (numeric-bound-test low2 low1 >= >) |
---|
2513 | (numeric-bound-test* low2 high1 <= <))) |
---|
2514 | (or (and (numeric-bound-test* low2 high1 <= <) |
---|
2515 | (numeric-bound-test low2 low1 >= >)) |
---|
2516 | (and (numeric-bound-test high2 high1 <= <) |
---|
2517 | (numeric-bound-test* high2 low1 >= >)))))))) |
---|
2518 | |
---|
2519 | ;;; Round-Numeric-Bound -- Internal |
---|
2520 | ;;; |
---|
2521 | ;;; Take the numeric bound X and convert it into something that can be used |
---|
2522 | ;;; as a bound in a numeric type with the specified Class and Format. If up-p |
---|
2523 | ;;; is true, then we round up as needed, otherwise we round down. Up-p true |
---|
2524 | ;;; implies that X is a lower bound, i.e. (N) > N. |
---|
2525 | ;;; |
---|
2526 | ;;; This is used by Numeric-Type-Intersection to mash the bound into the |
---|
2527 | ;;; appropriate type number. X may only be a float when Class is Float. |
---|
2528 | ;;; |
---|
2529 | ;;; ### Note: it is possible for the coercion to a float to overflow or |
---|
2530 | ;;; underflow. This happens when the bound doesn't fit in the specified |
---|
2531 | ;;; format. In this case, we should really return the appropriate |
---|
2532 | ;;; {Most | Least}-{Positive | Negative}-XXX-Float float of desired format. |
---|
2533 | ;;; But these conditions aren't currently signalled in any useful way. |
---|
2534 | ;;; |
---|
2535 | ;;; Also, when converting an open rational bound into a float we should |
---|
2536 | ;;; probably convert it to a closed bound of the closest float in the specified |
---|
2537 | ;;; format. In general, open float bounds are fucked. |
---|
2538 | ;;; |
---|
2539 | (defun round-numeric-bound (x class format up-p) |
---|
2540 | (if x |
---|
2541 | (let ((cx (if (consp x) (car x) x))) |
---|
2542 | (ecase class |
---|
2543 | ((nil rational) x) |
---|
2544 | (integer |
---|
2545 | (if (and (consp x) (integerp cx)) |
---|
2546 | (if up-p (1+ cx) (1- cx)) |
---|
2547 | (if up-p (ceiling cx) (floor cx)))) |
---|
2548 | (float |
---|
2549 | (let ((res (if format (coerce cx format) (float cx)))) |
---|
2550 | (if (consp x) (list res) res))))) |
---|
2551 | nil)) |
---|
2552 | |
---|
2553 | ;;; Number :Simple-Intersection type method -- Internal |
---|
2554 | ;;; |
---|
2555 | ;;; Handle the case of Type-Intersection on two numeric types. We use |
---|
2556 | ;;; Types-Intersect to throw out the case of types with no intersection. If an |
---|
2557 | ;;; attribute in Type1 is unspecified, then we use Type2's attribute, which |
---|
2558 | ;;; must be at least as restrictive. If the types intersect, then the only |
---|
2559 | ;;; attributes that can be specified and different are the class and the |
---|
2560 | ;;; bounds. |
---|
2561 | ;;; |
---|
2562 | ;;; When the class differs, we use the more restrictive class. The only |
---|
2563 | ;;; interesting case is rational/integer, since rational includes integer. |
---|
2564 | ;;; |
---|
2565 | ;;; We make the result lower (upper) bound the maximum (minimum) of the |
---|
2566 | ;;; argument lower (upper) bounds. We convert the bounds into the |
---|
2567 | ;;; appropriate numeric type before maximizing. This avoids possible confusion |
---|
2568 | ;;; due to mixed-type comparisons (but I think the result is the same). |
---|
2569 | ;;; |
---|
2570 | (define-type-method (number :simple-intersection) (type1 type2) |
---|
2571 | (declare (type numeric-type type1 type2)) |
---|
2572 | (if (numeric-types-intersect type1 type2) |
---|
2573 | (let* ((class1 (numeric-ctype-class type1)) |
---|
2574 | (class2 (numeric-ctype-class type2)) |
---|
2575 | (class (ecase class1 |
---|
2576 | ((nil) class2) |
---|
2577 | ((integer float) class1) |
---|
2578 | (rational (if (eq class2 'integer) 'integer 'rational)))) |
---|
2579 | (format (or (numeric-ctype-format type1) |
---|
2580 | (numeric-ctype-format type2)))) |
---|
2581 | (make-numeric-ctype |
---|
2582 | :class class |
---|
2583 | :format format |
---|
2584 | :complexp (or (numeric-ctype-complexp type1) |
---|
2585 | (numeric-ctype-complexp type2)) |
---|
2586 | :low (numeric-bound-max |
---|
2587 | (round-numeric-bound (numeric-ctype-low type1) |
---|
2588 | class format t) |
---|
2589 | (round-numeric-bound (numeric-ctype-low type2) |
---|
2590 | class format t) |
---|
2591 | > >= nil) |
---|
2592 | :high (numeric-bound-max |
---|
2593 | (round-numeric-bound (numeric-ctype-high type1) |
---|
2594 | class format nil) |
---|
2595 | (round-numeric-bound (numeric-ctype-high type2) |
---|
2596 | class format nil) |
---|
2597 | < <= nil))) |
---|
2598 | *empty-type*)) |
---|
2599 | |
---|
2600 | ;;; Float-Format-Max -- Interface |
---|
2601 | ;;; |
---|
2602 | ;;; Given two float formats, return the one with more precision. If either |
---|
2603 | ;;; one is null, return NIL. |
---|
2604 | ;;; |
---|
2605 | (defun float-format-max (f1 f2) |
---|
2606 | (when (and f1 f2) |
---|
2607 | (dolist (f float-formats (error "Bad float format: ~S." f1)) |
---|
2608 | (when (or (eq f f1) (eq f f2)) |
---|
2609 | (return f))))) |
---|
2610 | |
---|
2611 | |
---|
2612 | ;;; Numeric-Contagion -- Interface |
---|
2613 | ;;; |
---|
2614 | ;;; Return the result of an operation on Type1 and Type2 according to the |
---|
2615 | ;;; rules of numeric contagion. This is always NUMBER, some float format |
---|
2616 | ;;; (possibly complex) or RATIONAL. Due to rational canonicalization, there |
---|
2617 | ;;; isn't much we can do here with integers or rational complex numbers. |
---|
2618 | ;;; |
---|
2619 | ;;; If either argument is not a Numeric-Type, then return NUMBER. This is |
---|
2620 | ;;; useful mainly for allowing types that are technically numbers, but not a |
---|
2621 | ;;; Numeric-Type. |
---|
2622 | ;;; |
---|
2623 | (defun numeric-contagion (type1 type2) |
---|
2624 | (if (and (numeric-ctype-p type1) (numeric-ctype-p type2)) |
---|
2625 | (let ((class1 (numeric-ctype-class type1)) |
---|
2626 | (class2 (numeric-ctype-class type2)) |
---|
2627 | (format1 (numeric-ctype-format type1)) |
---|
2628 | (format2 (numeric-ctype-format type2)) |
---|
2629 | (complexp1 (numeric-ctype-complexp type1)) |
---|
2630 | (complexp2 (numeric-ctype-complexp type2))) |
---|
2631 | (cond ((or (null complexp1) |
---|
2632 | (null complexp2)) |
---|
2633 | (specifier-type 'number)) |
---|
2634 | ((eq class1 'float) |
---|
2635 | (make-numeric-ctype |
---|
2636 | :class 'float |
---|
2637 | :format (ecase class2 |
---|
2638 | (float (float-format-max format1 format2)) |
---|
2639 | ((integer rational) format1) |
---|
2640 | ((nil) |
---|
2641 | ;; A double-float with any real number is a |
---|
2642 | ;; double-float. |
---|
2643 | (if (eq format1 'double-float) |
---|
2644 | 'double-float |
---|
2645 | nil))) |
---|
2646 | :complexp (if (or (eq complexp1 :complex) |
---|
2647 | (eq complexp2 :complex)) |
---|
2648 | :complex |
---|
2649 | :real))) |
---|
2650 | ((eq class2 'float) (numeric-contagion type2 type1)) |
---|
2651 | ((and (eq complexp1 :real) (eq complexp2 :real)) |
---|
2652 | (make-numeric-ctype |
---|
2653 | :class (and class1 class2 'rational) |
---|
2654 | :complexp :real)) |
---|
2655 | (t |
---|
2656 | (specifier-type 'number)))) |
---|
2657 | (specifier-type 'number))) |
---|
2658 | |
---|
2659 | |
---|
2660 | |
---|
2661 | |
---|
2662 | ;;;; Array types: |
---|
2663 | |
---|
2664 | ;;; The Array-Type is used to represent all array types, including things such |
---|
2665 | ;;; as SIMPLE-STRING. |
---|
2666 | ;;; |
---|
2667 | |
---|
2668 | (defun make-array-ctype (&key |
---|
2669 | (dimensions '*) |
---|
2670 | (complexp '*) |
---|
2671 | element-type |
---|
2672 | (specialized-element-type *wild-type*)) |
---|
2673 | (%istruct 'array-ctype |
---|
2674 | (type-class-or-lose 'array) |
---|
2675 | nil |
---|
2676 | dimensions |
---|
2677 | complexp |
---|
2678 | element-type |
---|
2679 | specialized-element-type |
---|
2680 | (unless (eq specialized-element-type *wild-type*) |
---|
2681 | (ctype-subtype specialized-element-type)))) |
---|
2682 | |
---|
2683 | (defun array-ctype-p (x) (istruct-typep x 'array-ctype)) |
---|
2684 | (setf (type-predicate 'array-ctype) 'array-ctype-p) |
---|
2685 | |
---|
2686 | ;;; Specialized-Element-Type-Maybe -- Internal |
---|
2687 | ;;; |
---|
2688 | ;;; What this does depends on the setting of the |
---|
2689 | ;;; *use-implementation-types* switch. If true, return the specialized element |
---|
2690 | ;;; type, otherwise return the original element type. |
---|
2691 | ;;; |
---|
2692 | (defun specialized-element-type-maybe (type) |
---|
2693 | (declare (type array-ctype type)) |
---|
2694 | (if *use-implementation-types* |
---|
2695 | (array-ctype-specialized-element-type type) |
---|
2696 | (array-ctype-element-type type))) |
---|
2697 | |
---|
2698 | (define-type-method (array :simple-=) (type1 type2) |
---|
2699 | (if (or (unknown-ctype-p (array-ctype-element-type type1)) |
---|
2700 | (unknown-ctype-p (array-ctype-element-type type2))) |
---|
2701 | (multiple-value-bind (equalp certainp) |
---|
2702 | (type= (array-ctype-element-type type1) |
---|
2703 | (array-ctype-element-type type2)) |
---|
2704 | (assert (not (and (not equalp) certainp))) |
---|
2705 | (values equalp certainp)) |
---|
2706 | (values (and (equal (array-ctype-dimensions type1) |
---|
2707 | (array-ctype-dimensions type2)) |
---|
2708 | (eq (array-ctype-complexp type1) |
---|
2709 | (array-ctype-complexp type2)) |
---|
2710 | (type= (specialized-element-type-maybe type1) |
---|
2711 | (specialized-element-type-maybe type2))) |
---|
2712 | t))) |
---|
2713 | |
---|
2714 | (define-type-method (array :unparse) (type) |
---|
2715 | (let ((dims (array-ctype-dimensions type)) |
---|
2716 | (eltype (type-specifier (array-ctype-element-type type))) |
---|
2717 | (complexp (array-ctype-complexp type))) |
---|
2718 | (cond ((eq dims '*) |
---|
2719 | (if (eq eltype '*) |
---|
2720 | (if complexp 'array 'simple-array) |
---|
2721 | (if complexp `(array ,eltype) `(simple-array ,eltype)))) |
---|
2722 | ((= (length dims) 1) |
---|
2723 | (if complexp |
---|
2724 | (if (eq (car dims) '*) |
---|
2725 | (case eltype |
---|
2726 | (bit 'bit-vector) |
---|
2727 | ((character base-char) 'base-string) |
---|
2728 | (* 'vector) |
---|
2729 | (t `(vector ,eltype))) |
---|
2730 | (case eltype |
---|
2731 | (bit `(bit-vector ,(car dims))) |
---|
2732 | ((character base-char) `(base-string ,(car dims))) |
---|
2733 | (t `(vector ,eltype ,(car dims))))) |
---|
2734 | (if (eq (car dims) '*) |
---|
2735 | (case eltype |
---|
2736 | (bit 'simple-bit-vector) |
---|
2737 | ((base-char character) 'simple-base-string) |
---|
2738 | ((t) 'simple-vector) |
---|
2739 | (t `(simple-array ,eltype (*)))) |
---|
2740 | (case eltype |
---|
2741 | (bit `(simple-bit-vector ,(car dims))) |
---|
2742 | ((base-char character) `(simple-base-string ,(car dims))) |
---|
2743 | ((t) `(simple-vector ,(car dims))) |
---|
2744 | (t `(simple-array ,eltype ,dims)))))) |
---|
2745 | (t |
---|
2746 | (if complexp |
---|
2747 | `(array ,eltype ,dims) |
---|
2748 | `(simple-array ,eltype ,dims)))))) |
---|
2749 | |
---|
2750 | (define-type-method (array :simple-subtypep) (type1 type2) |
---|
2751 | (let ((dims1 (array-ctype-dimensions type1)) |
---|
2752 | (dims2 (array-ctype-dimensions type2)) |
---|
2753 | (complexp2 (array-ctype-complexp type2))) |
---|
2754 | (cond (;; not subtypep unless dimensions are compatible |
---|
2755 | (not (or (eq dims2 '*) |
---|
2756 | (and (not (eq dims1 '*)) |
---|
2757 | (= (length (the list dims1)) |
---|
2758 | (length (the list dims2))) |
---|
2759 | (every (lambda (x y) |
---|
2760 | (or (eq y '*) (eql x y))) |
---|
2761 | (the list dims1) |
---|
2762 | (the list dims2))))) |
---|
2763 | (values nil t)) |
---|
2764 | ;; not subtypep unless complexness is compatible |
---|
2765 | ((not (or (eq complexp2 :maybe) |
---|
2766 | (eq (array-ctype-complexp type1) complexp2))) |
---|
2767 | (values nil t)) |
---|
2768 | ;; Since we didn't fail any of the tests above, we win |
---|
2769 | ;; if the TYPE2 element type is wild. |
---|
2770 | ((eq (array-ctype-element-type type2) *wild-type*) |
---|
2771 | (values t t)) |
---|
2772 | (;; Since we didn't match any of the special cases above, we |
---|
2773 | ;; can't give a good answer unless both the element types |
---|
2774 | ;; have been defined. |
---|
2775 | (or (unknown-ctype-p (array-ctype-element-type type1)) |
---|
2776 | (unknown-ctype-p (array-ctype-element-type type2))) |
---|
2777 | (values nil nil)) |
---|
2778 | (;; Otherwise, the subtype relationship holds iff the |
---|
2779 | ;; types are equal, and they're equal iff the specialized |
---|
2780 | ;; element types are identical. |
---|
2781 | t |
---|
2782 | (values (type= (specialized-element-type-maybe type1) |
---|
2783 | (specialized-element-type-maybe type2)) |
---|
2784 | t))))) |
---|
2785 | |
---|
2786 | ; (define-superclasses array (string string) (vector vector) (array)) |
---|
2787 | |
---|
2788 | |
---|
2789 | (defun array-types-intersect (type1 type2) |
---|
2790 | (declare (type array-ctype type1 type2)) |
---|
2791 | (let ((dims1 (array-ctype-dimensions type1)) |
---|
2792 | (dims2 (array-ctype-dimensions type2)) |
---|
2793 | (complexp1 (array-ctype-complexp type1)) |
---|
2794 | (complexp2 (array-ctype-complexp type2))) |
---|
2795 | ;; See whether dimensions are compatible. |
---|
2796 | (cond ((not (or (eq dims1 '*) (eq dims2 '*) |
---|
2797 | (and (= (length dims1) (length dims2)) |
---|
2798 | (every (lambda (x y) |
---|
2799 | (or (eq x '*) (eq y '*) (= x y))) |
---|
2800 | dims1 dims2)))) |
---|
2801 | (values nil t)) |
---|
2802 | ;; See whether complexpness is compatible. |
---|
2803 | ((not (or (eq complexp1 :maybe) |
---|
2804 | (eq complexp2 :maybe) |
---|
2805 | (eq complexp1 complexp2))) |
---|
2806 | (values nil t)) |
---|
2807 | ((or (eq (array-ctype-specialized-element-type type1) *wild-type*) |
---|
2808 | (eq (array-ctype-specialized-element-type type2) *wild-type*) |
---|
2809 | (type= (specialized-element-type-maybe type1) |
---|
2810 | (specialized-element-type-maybe type2))) |
---|
2811 | (values t t)) |
---|
2812 | (t |
---|
2813 | (values nil t))))) |
---|
2814 | |
---|
2815 | (define-type-method (array :simple-intersection) (type1 type2) |
---|
2816 | (declare (type array-ctype type1 type2)) |
---|
2817 | (if (array-types-intersect type1 type2) |
---|
2818 | (let ((dims1 (array-ctype-dimensions type1)) |
---|
2819 | (dims2 (array-ctype-dimensions type2)) |
---|
2820 | (complexp1 (array-ctype-complexp type1)) |
---|
2821 | (complexp2 (array-ctype-complexp type2)) |
---|
2822 | (eltype1 (array-ctype-element-type type1)) |
---|
2823 | (eltype2 (array-ctype-element-type type2))) |
---|
2824 | (specialize-array-type |
---|
2825 | (make-array-ctype |
---|
2826 | :dimensions (cond ((eq dims1 '*) dims2) |
---|
2827 | ((eq dims2 '*) dims1) |
---|
2828 | (t |
---|
2829 | (mapcar #'(lambda (x y) (if (eq x '*) y x)) |
---|
2830 | dims1 dims2))) |
---|
2831 | :complexp (if (eq complexp1 :maybe) complexp2 complexp1) |
---|
2832 | :element-type (cond |
---|
2833 | ((eq eltype1 *wild-type*) eltype2) |
---|
2834 | ((eq eltype2 *wild-type*) eltype1) |
---|
2835 | (t (type-intersection eltype1 eltype2)))))) |
---|
2836 | *empty-type*)) |
---|
2837 | |
---|
2838 | ;;; Check-Array-Dimensions -- Internal |
---|
2839 | ;;; |
---|
2840 | ;;; Check a supplied dimension list to determine if it is legal. |
---|
2841 | ;;; |
---|
2842 | (defun check-array-dimensions (dims) |
---|
2843 | (typecase dims |
---|
2844 | ((member *) dims) |
---|
2845 | (integer |
---|
2846 | (when (minusp dims) |
---|
2847 | (signal-program-error "Arrays can't have a negative number of dimensions: ~D." dims)) |
---|
2848 | (when (>= dims array-rank-limit) |
---|
2849 | (signal-program-error "Array type has too many dimensions: ~S." dims)) |
---|
2850 | (make-list dims :initial-element '*)) |
---|
2851 | (list |
---|
2852 | (when (>= (length dims) array-rank-limit) |
---|
2853 | (signal-program-error "Array type has too many dimensions: ~S." dims)) |
---|
2854 | (dolist (dim dims) |
---|
2855 | (unless (eq dim '*) |
---|
2856 | (unless (and (integerp dim) |
---|
2857 | (>= dim 0) (< dim array-dimension-limit)) |
---|
2858 | (signal-program-error "Bad dimension in array type: ~S." dim)))) |
---|
2859 | dims) |
---|
2860 | (t |
---|
2861 | (signal-program-error "Array dimensions is not a list, integer or *:~% ~S" |
---|
2862 | dims)))) |
---|
2863 | |
---|
2864 | (def-type-translator array (&optional element-type dimensions &environment env) |
---|
2865 | (specialize-array-type |
---|
2866 | (make-array-ctype :dimensions (check-array-dimensions dimensions) |
---|
2867 | :complexp :maybe |
---|
2868 | :element-type (specifier-type element-type env)))) |
---|
2869 | |
---|
2870 | (def-type-translator simple-array (&optional element-type dimensions &environment env) |
---|
2871 | (specialize-array-type |
---|
2872 | (make-array-ctype :dimensions (check-array-dimensions dimensions) |
---|
2873 | :element-type (specifier-type element-type env) |
---|
2874 | :complexp nil))) |
---|
2875 | |
---|
2876 | ;;; Order matters here. |
---|
2877 | (defparameter specialized-array-element-types |
---|
2878 | '(nil bit (unsigned-byte 8) (signed-byte 8) (unsigned-byte 16) |
---|
2879 | (signed-byte 16) (unsigned-byte 32) #+32-bit-target fixnum (signed-byte 32) |
---|
2880 | #+64-bit-target (unsigned-byte 64) |
---|
2881 | #+64-bit-target fixnum |
---|
2882 | #+64-bit-target (signed-byte 64) |
---|
2883 | character short-float double-float)) |
---|
2884 | |
---|
2885 | (defun specialize-array-type (type) |
---|
2886 | (let* ((eltype (array-ctype-element-type type)) |
---|
2887 | (specialized-type (if (eq eltype *wild-type*) |
---|
2888 | *wild-type* |
---|
2889 | (dolist (stype-name specialized-array-element-types |
---|
2890 | *universal-type*) |
---|
2891 | (let ((stype (specifier-type stype-name))) |
---|
2892 | (when (csubtypep eltype stype) |
---|
2893 | (return stype))))))) |
---|
2894 | |
---|
2895 | (setf (array-ctype-specialized-element-type type) specialized-type |
---|
2896 | (array-ctype-typecode type) (unless (eq specialized-type *wild-type*) |
---|
2897 | (ctype-subtype specialized-type))) |
---|
2898 | type)) |
---|
2899 | |
---|
2900 | |
---|
2901 | ;;;; Member types. |
---|
2902 | |
---|
2903 | ;;; The Member-Type represents uses of the MEMBER type specifier. We bother |
---|
2904 | ;;; with this at this level because MEMBER types are fairly important and union |
---|
2905 | ;;; and intersection are well defined. |
---|
2906 | |
---|
2907 | (defun %make-member-ctype (members) |
---|
2908 | (%istruct 'member-ctype |
---|
2909 | (type-class-or-lose 'member) |
---|
2910 | t |
---|
2911 | members)) |
---|
2912 | |
---|
2913 | (defun make-member-ctype (&key members) |
---|
2914 | (let* ((singlep (subsetp '(-0.0f0 0.0f0) members)) |
---|
2915 | (doublep (subsetp '(-0.0d0 0.0d0) members)) |
---|
2916 | (union-types |
---|
2917 | (if singlep |
---|
2918 | (if doublep |
---|
2919 | (list *ctype-of-single-float-0* *ctype-of-double-float-0*) |
---|
2920 | (list *ctype-of-single-float-0*)) |
---|
2921 | (if doublep |
---|
2922 | (list *ctype-of-double-float-0*))))) |
---|
2923 | (if union-types |
---|
2924 | (progn |
---|
2925 | (if singlep |
---|
2926 | (setq members (set-difference '(-0.0f0 0.0f0) members))) |
---|
2927 | (if doublep |
---|
2928 | (setq members (set-difference '(-0.d00 0.0d0) members))) |
---|
2929 | (make-union-ctype (if (null members) |
---|
2930 | union-types |
---|
2931 | (cons (%make-member-ctype members) union-types)))) |
---|
2932 | (%make-member-ctype members)))) |
---|
2933 | |
---|
2934 | |
---|
2935 | (defun member-ctype-p (x) (istruct-typep x 'member-ctype)) |
---|
2936 | (setf (type-predicate 'member-ctype) 'member-ctype-p) |
---|
2937 | |
---|
2938 | (define-type-method (member :unparse) (type) |
---|
2939 | (if (type= type (specifier-type 'standard-char)) |
---|
2940 | 'standard-char |
---|
2941 | (let ((members (member-ctype-members type))) |
---|
2942 | (if (equal members '(nil)) |
---|
2943 | 'null |
---|
2944 | `(member ,@members))))) |
---|
2945 | |
---|
2946 | (define-type-method (member :simple-subtypep) (type1 type2) |
---|
2947 | (values (subsetp (member-ctype-members type1) (member-ctype-members type2)) |
---|
2948 | t)) |
---|
2949 | |
---|
2950 | |
---|
2951 | (define-type-method (member :complex-subtypep-arg1) (type1 type2) |
---|
2952 | (every/type (swapped-args-fun #'ctypep) |
---|
2953 | type2 |
---|
2954 | (member-ctype-members type1))) |
---|
2955 | |
---|
2956 | ;;; We punt if the odd type is enumerable and intersects with the member type. |
---|
2957 | ;;; If not enumerable, then it is definitely not a subtype of the member type. |
---|
2958 | ;;; |
---|
2959 | (define-type-method (member :complex-subtypep-arg2) (type1 type2) |
---|
2960 | (cond ((not (ctype-enumerable type1)) (values nil t)) |
---|
2961 | ((types-intersect type1 type2) |
---|
2962 | (invoke-complex-subtypep-arg1-method type1 type2)) |
---|
2963 | (t |
---|
2964 | (values nil t)))) |
---|
2965 | |
---|
2966 | (define-type-method (member :simple-intersection) (type1 type2) |
---|
2967 | (let ((mem1 (member-ctype-members type1)) |
---|
2968 | (mem2 (member-ctype-members type2))) |
---|
2969 | (values (cond ((subsetp mem1 mem2) type1) |
---|
2970 | ((subsetp mem2 mem1) type2) |
---|
2971 | (t |
---|
2972 | (let ((res (intersection mem1 mem2))) |
---|
2973 | (if res |
---|
2974 | (make-member-ctype :members res) |
---|
2975 | *empty-type*)))) |
---|
2976 | t))) |
---|
2977 | |
---|
2978 | (define-type-method (member :complex-intersection) (type1 type2) |
---|
2979 | (block PUNT |
---|
2980 | (collect ((members)) |
---|
2981 | (let ((mem2 (member-ctype-members type2))) |
---|
2982 | (dolist (member mem2) |
---|
2983 | (multiple-value-bind (val win) (ctypep member type1) |
---|
2984 | (unless win |
---|
2985 | (return-from punt nil)) |
---|
2986 | (when val (members member)))) |
---|
2987 | (cond ((subsetp mem2 (members)) type2) |
---|
2988 | ((null (members)) *empty-type*) |
---|
2989 | (t |
---|
2990 | (make-member-ctype :members (members)))))))) |
---|
2991 | |
---|
2992 | ;;; We don't need a :COMPLEX-UNION, since the only interesting case is a union |
---|
2993 | ;;; type, and the member/union interaction is handled by the union type |
---|
2994 | ;;; method. |
---|
2995 | (define-type-method (member :simple-union) (type1 type2) |
---|
2996 | (let ((mem1 (member-ctype-members type1)) |
---|
2997 | (mem2 (member-ctype-members type2))) |
---|
2998 | (cond ((subsetp mem1 mem2) type2) |
---|
2999 | ((subsetp mem2 mem1) type1) |
---|
3000 | (t |
---|
3001 | (make-member-ctype :members (union mem1 mem2)))))) |
---|
3002 | |
---|
3003 | |
---|
3004 | (define-type-method (member :simple-=) (type1 type2) |
---|
3005 | (let ((mem1 (member-ctype-members type1)) |
---|
3006 | (mem2 (member-ctype-members type2))) |
---|
3007 | (values (and (subsetp mem1 mem2) (subsetp mem2 mem1)) |
---|
3008 | t))) |
---|
3009 | |
---|
3010 | (define-type-method (member :complex-=) (type1 type2) |
---|
3011 | (if (ctype-enumerable type1) |
---|
3012 | (multiple-value-bind (val win) |
---|
3013 | (csubtypep type2 type1) |
---|
3014 | (if (or val (not win)) |
---|
3015 | (values nil nil) |
---|
3016 | (values nil t))) |
---|
3017 | (values nil t))) |
---|
3018 | |
---|
3019 | (def-type-translator member (&rest members) |
---|
3020 | (if members |
---|
3021 | (collect ((non-numbers) (numbers)) |
---|
3022 | (dolist (m (remove-duplicates members)) |
---|
3023 | (if (and (numberp m) |
---|
3024 | (not (and (floatp m) (zerop m)))) |
---|
3025 | (numbers (ctype-of m)) |
---|
3026 | (non-numbers m))) |
---|
3027 | (apply #'type-union |
---|
3028 | (if (non-numbers) |
---|
3029 | (make-member-ctype :members (non-numbers)) |
---|
3030 | *empty-type*) |
---|
3031 | (numbers))) |
---|
3032 | *empty-type*)) |
---|
3033 | |
---|
3034 | |
---|
3035 | |
---|
3036 | ;;;; Union types: |
---|
3037 | |
---|
3038 | ;;; The Union-Type represents uses of the OR type specifier which can't be |
---|
3039 | ;;; canonicalized to something simpler. Canonical form: |
---|
3040 | ;;; |
---|
3041 | ;;; 1] There is never more than one Member-Type component. |
---|
3042 | ;;; 2] There are never any Union-Type components. |
---|
3043 | ;;; |
---|
3044 | |
---|
3045 | (defun make-union-ctype (types) |
---|
3046 | (declare (list types)) |
---|
3047 | (%istruct 'union-ctype |
---|
3048 | (type-class-or-lose 'union) |
---|
3049 | (every #'(lambda (x) (ctype-enumerable x)) types) |
---|
3050 | types)) |
---|
3051 | |
---|
3052 | (defun union-ctype-p (x) (istruct-typep x 'union-ctype)) |
---|
3053 | (setf (type-predicate 'union-ctype) 'union-ctype-p) |
---|
3054 | |
---|
3055 | |
---|
3056 | ;;; If List, then return that, otherwise the OR of the component types. |
---|
3057 | ;;; |
---|
3058 | (define-type-method (union :unparse) (type) |
---|
3059 | (declare (type ctype type)) |
---|
3060 | (cond |
---|
3061 | ((type= type (specifier-type 'list)) 'list) |
---|
3062 | ((type= type (specifier-type 'float)) 'float) |
---|
3063 | ((type= type (specifier-type 'real)) 'real) |
---|
3064 | ((type= type (specifier-type 'sequence)) 'sequence) |
---|
3065 | ((type= type (specifier-type 'bignum)) 'bignum) |
---|
3066 | (t `(or ,@(mapcar #'type-specifier (union-ctype-types type)))))) |
---|
3067 | |
---|
3068 | |
---|
3069 | |
---|
3070 | (define-type-method (union :simple-=) (type1 type2) |
---|
3071 | (multiple-value-bind (subtype certain?) |
---|
3072 | (csubtypep type1 type2) |
---|
3073 | (if subtype |
---|
3074 | (csubtypep type2 type1) |
---|
3075 | (if certain? |
---|
3076 | (values nil t) |
---|
3077 | (multiple-value-bind (subtype certain?) |
---|
3078 | (csubtypep type2 type1) |
---|
3079 | (declare (ignore subtype)) |
---|
3080 | (values nil certain?)))))) |
---|
3081 | |
---|
3082 | |
---|
3083 | (define-type-method (union :complex-=) (type1 type2) |
---|
3084 | (declare (ignore type1)) |
---|
3085 | (if (some #'type-might-contain-other-types-p |
---|
3086 | (union-ctype-types type2)) |
---|
3087 | (values nil nil) |
---|
3088 | (values nil t))) |
---|
3089 | |
---|
3090 | |
---|
3091 | (defun union-simple-subtypep (type1 type2) |
---|
3092 | (every/type (swapped-args-fun #'union-complex-subtypep-arg2) |
---|
3093 | type2 |
---|
3094 | (union-ctype-types type1))) |
---|
3095 | |
---|
3096 | (define-type-method (union :simple-subtypep) (type1 type2) |
---|
3097 | (union-simple-subtypep type1 type2)) |
---|
3098 | |
---|
3099 | (defun union-complex-subtypep-arg1 (type1 type2) |
---|
3100 | (every/type (swapped-args-fun #'csubtypep) |
---|
3101 | type2 |
---|
3102 | (union-ctype-types type1))) |
---|
3103 | |
---|
3104 | (define-type-method (union :complex-subtypep-arg1) (type1 type2) |
---|
3105 | (union-complex-subtypep-arg1 type1 type2)) |
---|
3106 | |
---|
3107 | (defun union-complex-subtypep-arg2 (type1 type2) |
---|
3108 | (multiple-value-bind (sub-value sub-certain?) |
---|
3109 | (progn |
---|
3110 | (assert (union-ctype-p type2)) |
---|
3111 | (assert (not (union-ctype-p type1))) |
---|
3112 | (type= type1 |
---|
3113 | (apply #'type-union |
---|
3114 | (mapcar (lambda (x) (type-intersection type1 x)) |
---|
3115 | (union-ctype-types type2))))) |
---|
3116 | (if sub-certain? |
---|
3117 | (values sub-value sub-certain?) |
---|
3118 | (invoke-complex-subtypep-arg1-method type1 type2)))) |
---|
3119 | |
---|
3120 | (define-type-method (union :complex-subtypep-arg2) (type1 type2) |
---|
3121 | (union-complex-subtypep-arg2 type1 type2)) |
---|
3122 | |
---|
3123 | (define-type-method (union :simple-intersection :complex-intersection) |
---|
3124 | (type1 type2) |
---|
3125 | (assert (union-ctype-p type2)) |
---|
3126 | (cond ((and (union-ctype-p type1) |
---|
3127 | (union-simple-subtypep type1 type2)) type1) |
---|
3128 | ((and (union-ctype-p type1) |
---|
3129 | (union-simple-subtypep type2 type1)) type2) |
---|
3130 | ((and (not (union-ctype-p type1)) |
---|
3131 | (union-complex-subtypep-arg2 type1 type2)) |
---|
3132 | type1) |
---|
3133 | ((and (not (union-ctype-p type1)) |
---|
3134 | (union-complex-subtypep-arg1 type2 type1)) |
---|
3135 | type2) |
---|
3136 | (t |
---|
3137 | (let ((accumulator *empty-type*)) |
---|
3138 | (dolist (t2 (union-ctype-types type2) accumulator) |
---|
3139 | (setf accumulator |
---|
3140 | (type-union accumulator |
---|
3141 | (type-intersection type1 t2)))))))) |
---|
3142 | |
---|
3143 | |
---|
3144 | |
---|
3145 | (def-type-translator or (&rest type-specifiers &environment env) |
---|
3146 | (apply #'type-union |
---|
3147 | (mapcar #'(lambda (spec) (specifier-type spec env)) type-specifiers))) |
---|
3148 | |
---|
3149 | |
---|
3150 | ;;; Intersection types |
---|
3151 | (defun make-intersection-ctype (enumerable types) |
---|
3152 | (%istruct 'intersection-ctype |
---|
3153 | (type-class-or-lose 'intersection) |
---|
3154 | enumerable |
---|
3155 | types)) |
---|
3156 | |
---|
3157 | (defun intersection-ctype-p (x) |
---|
3158 | (istruct-typep x 'intersection-ctype)) |
---|
3159 | (setf (type-predicate 'intersection-ctype) 'intersection-ctype-p) |
---|
3160 | |
---|
3161 | (define-type-method (intersection :unparse) (type) |
---|
3162 | (declare (type ctype type)) |
---|
3163 | (or (find type '(ratio keyword) :key #'specifier-type :test #'type=) |
---|
3164 | `(and ,@(mapcar #'type-specifier (intersection-ctype-types type))))) |
---|
3165 | |
---|
3166 | ;;; shared machinery for type equality: true if every type in the set |
---|
3167 | ;;; TYPES1 matches a type in the set TYPES2 and vice versa |
---|
3168 | (defun type=-set (types1 types2) |
---|
3169 | (flet (;; true if every type in the set X matches a type in the set Y |
---|
3170 | (type<=-set (x y) |
---|
3171 | (declare (type list x y)) |
---|
3172 | (every (lambda (xelement) |
---|
3173 | (position xelement y :test #'type=)) |
---|
3174 | x))) |
---|
3175 | (values (and (type<=-set types1 types2) |
---|
3176 | (type<=-set types2 types1)) |
---|
3177 | t))) |
---|
3178 | |
---|
3179 | (define-type-method (intersection :simple-=) (type1 type2) |
---|
3180 | (type=-set (intersection-ctype-types type1) |
---|
3181 | (intersection-ctype-types type2))) |
---|
3182 | |
---|
3183 | (defun %intersection-complex-subtypep-arg1 (type1 type2) |
---|
3184 | (type= type1 (type-intersection type1 type2))) |
---|
3185 | |
---|
3186 | (defun %intersection-simple-subtypep (type1 type2) |
---|
3187 | (every/type #'%intersection-complex-subtypep-arg1 |
---|
3188 | type1 |
---|
3189 | (intersection-ctype-types type2))) |
---|
3190 | |
---|
3191 | (define-type-method (intersection :simple-subtypep) (type1 type2) |
---|
3192 | (%intersection-simple-subtypep type1 type2)) |
---|
3193 | |
---|
3194 | (define-type-method (intersection :complex-subtypep-arg1) (type1 type2) |
---|
3195 | (%intersection-complex-subtypep-arg1 type1 type2)) |
---|
3196 | |
---|
3197 | (defun %intersection-complex-subtypep-arg2 (type1 type2) |
---|
3198 | (every/type #'csubtypep type1 (intersection-ctype-types type2))) |
---|
3199 | |
---|
3200 | (define-type-method (intersection :complex-subtypep-arg2) (type1 type2) |
---|
3201 | (%intersection-complex-subtypep-arg2 type1 type2)) |
---|
3202 | |
---|
3203 | (define-type-method (intersection :simple-union :complex-union) |
---|
3204 | (type1 type2) |
---|
3205 | (assert (intersection-ctype-p type2)) |
---|
3206 | (cond ((and (intersection-ctype-p type1) |
---|
3207 | (%intersection-simple-subtypep type1 type2)) type2) |
---|
3208 | ((and (intersection-ctype-p type1) |
---|
3209 | (%intersection-simple-subtypep type2 type1)) type1) |
---|
3210 | ((and (not (intersection-ctype-p type1)) |
---|
3211 | (%intersection-complex-subtypep-arg2 type1 type2)) |
---|
3212 | type2) |
---|
3213 | ((and (not (intersection-ctype-p type1)) |
---|
3214 | (%intersection-complex-subtypep-arg1 type2 type1)) |
---|
3215 | type1) |
---|
3216 | ((and (csubtypep type2 (specifier-type 'ratio)) |
---|
3217 | (numeric-ctype-p type1) |
---|
3218 | (csubtypep type1 (specifier-type 'integer)) |
---|
3219 | (csubtypep type2 |
---|
3220 | (make-numeric-ctype |
---|
3221 | :class 'rational |
---|
3222 | :complexp nil |
---|
3223 | :low (if (null (numeric-ctype-low type1)) |
---|
3224 | nil |
---|
3225 | (list (1- (numeric-ctype-low type1)))) |
---|
3226 | :high (if (null (numeric-ctype-high type1)) |
---|
3227 | nil |
---|
3228 | (list (1+ (numeric-ctype-high type1))))))) |
---|
3229 | (type-union type1 |
---|
3230 | (apply #'type-intersection |
---|
3231 | (remove (specifier-type '(not integer)) |
---|
3232 | (intersection-ctype-types type2) |
---|
3233 | :test #'type=)))) |
---|
3234 | (t |
---|
3235 | (let ((accumulator *universal-type*)) |
---|
3236 | (do ((t2s (intersection-ctype-types type2) (cdr t2s))) |
---|
3237 | ((null t2s) accumulator) |
---|
3238 | (let ((union (type-union type1 (car t2s)))) |
---|
3239 | (when (union-ctype-p union) |
---|
3240 | (if (and (eq accumulator *universal-type*) |
---|
3241 | (null (cdr t2s))) |
---|
3242 | (return union) |
---|
3243 | (return nil))) |
---|
3244 | (setf accumulator |
---|
3245 | (type-intersection accumulator union)))))))) |
---|
3246 | |
---|
3247 | (def-type-translator and (&rest type-specifiers &environment env) |
---|
3248 | (apply #'type-intersection |
---|
3249 | (mapcar #'(lambda (spec) (specifier-type spec env)) |
---|
3250 | type-specifiers))) |
---|
3251 | |
---|
3252 | ;;; cons-ctype |
---|
3253 | (defun wild-ctype-to-universal-ctype (c) |
---|
3254 | (if (type= c *wild-type*) |
---|
3255 | *universal-type* |
---|
3256 | c)) |
---|
3257 | |
---|
3258 | (defun make-cons-ctype (car-ctype-value cdr-ctype-value) |
---|
3259 | (if (or (eq car-ctype-value *empty-type*) |
---|
3260 | (eq cdr-ctype-value *empty-type*)) |
---|
3261 | *empty-type* |
---|
3262 | (%istruct 'cons-ctype |
---|
3263 | (type-class-or-lose 'cons) |
---|
3264 | nil |
---|
3265 | (wild-ctype-to-universal-ctype car-ctype-value) |
---|
3266 | (wild-ctype-to-universal-ctype cdr-ctype-value)))) |
---|
3267 | |
---|
3268 | (defun cons-ctype-p (x) |
---|
3269 | (istruct-typep x 'cons-ctype)) |
---|
3270 | |
---|
3271 | (setf (type-predicate 'cons-ctype) 'cons-ctype-p) |
---|
3272 | |
---|
3273 | (def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*) &environment env) |
---|
3274 | (make-cons-ctype (specifier-type car-type-spec env) |
---|
3275 | (specifier-type cdr-type-spec env))) |
---|
3276 | |
---|
3277 | (define-type-method (cons :unparse) (type) |
---|
3278 | (let* ((car-spec (type-specifier (cons-ctype-car-ctype type))) |
---|
3279 | (cdr-spec (type-specifier (cons-ctype-cdr-ctype type)))) |
---|
3280 | (if (and (member car-spec '(t *)) |
---|
3281 | (member cdr-spec '(t *))) |
---|
3282 | 'cons |
---|
3283 | `(cons ,car-spec ,cdr-spec)))) |
---|
3284 | |
---|
3285 | (define-type-method (cons :simple-=) (type1 type2) |
---|
3286 | (declare (cons-ctype type1 type2)) |
---|
3287 | (and (type= (cons-ctype-car-ctype type1) (cons-ctype-car-ctype type2)) |
---|
3288 | (type= (cons-ctype-cdr-ctype type1) (cons-ctype-cdr-ctype type2)))) |
---|
3289 | |
---|
3290 | (define-type-method (cons :simple-subtypep) (type1 type2) |
---|
3291 | (declare (cons-ctype type1 type2)) |
---|
3292 | (multiple-value-bind (val-car win-car) |
---|
3293 | (csubtypep (cons-ctype-car-ctype type1) (cons-ctype-car-ctype type2)) |
---|
3294 | (multiple-value-bind (val-cdr win-cdr) |
---|
3295 | (csubtypep (cons-ctype-cdr-ctype type1) (cons-ctype-cdr-ctype type2)) |
---|
3296 | (if (and val-car val-cdr) |
---|
3297 | (values t (and win-car win-cdr)) |
---|
3298 | (values nil (or win-car win-cdr)))))) |
---|
3299 | |
---|
3300 | (define-type-method (cons :simple-union) (type1 type2) |
---|
3301 | (declare (type cons-ctype type1 type2)) |
---|
3302 | (let ((car-type1 (cons-ctype-car-ctype type1)) |
---|
3303 | (car-type2 (cons-ctype-car-ctype type2)) |
---|
3304 | (cdr-type1 (cons-ctype-cdr-ctype type1)) |
---|
3305 | (cdr-type2 (cons-ctype-cdr-ctype type2)) |
---|
3306 | (car-not1) |
---|
3307 | (car-not2)) |
---|
3308 | (macrolet ((frob-car (car1 car2 cdr1 cdr2 |
---|
3309 | &optional (not1 nil not1p)) |
---|
3310 | `(type-union |
---|
3311 | (make-cons-ctype ,car1 (type-union ,cdr1 ,cdr2)) |
---|
3312 | (make-cons-ctype |
---|
3313 | (type-intersection |
---|
3314 | ,car2 |
---|
3315 | ,(if not1p |
---|
3316 | not1 |
---|
3317 | `(specifier-type |
---|
3318 | `(not ,(type-specifier ,car1))))) |
---|
3319 | ,cdr2)))) |
---|
3320 | (cond ((type= car-type1 car-type2) |
---|
3321 | (make-cons-ctype car-type1 |
---|
3322 | (type-union cdr-type1 cdr-type2))) |
---|
3323 | ((type= cdr-type1 cdr-type2) |
---|
3324 | (make-cons-ctype (type-union car-type1 car-type2) |
---|
3325 | cdr-type1)) |
---|
3326 | ((csubtypep car-type1 car-type2) |
---|
3327 | (frob-car car-type1 car-type2 cdr-type1 cdr-type2)) |
---|
3328 | ((csubtypep car-type2 car-type1) |
---|
3329 | (frob-car car-type2 car-type1 cdr-type2 cdr-type1)) |
---|
3330 | ;; more general case of the above, but harder to compute |
---|
3331 | ((progn |
---|
3332 | (setf car-not1 (specifier-type |
---|
3333 | `(not ,(type-specifier car-type1)))) |
---|
3334 | (not (csubtypep car-type2 car-not1))) |
---|
3335 | (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1)) |
---|
3336 | ((progn |
---|
3337 | (setf car-not2 (specifier-type |
---|
3338 | `(not ,(type-specifier car-type2)))) |
---|
3339 | (not (csubtypep car-type1 car-not2))) |
---|
3340 | (frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2)))))) |
---|
3341 | |
---|
3342 | (define-type-method (cons :simple-intersection) (type1 type2) |
---|
3343 | (declare (type cons-type type1 type2)) |
---|
3344 | (let ((car-int2 (type-intersection2 (cons-ctype-car-ctype type1) |
---|
3345 | (cons-ctype-car-ctype type2))) |
---|
3346 | (cdr-int2 (type-intersection2 (cons-ctype-cdr-ctype type1) |
---|
3347 | (cons-ctype-cdr-ctype type2)))) |
---|
3348 | (cond ((and car-int2 cdr-int2) |
---|
3349 | (make-cons-ctype car-int2 cdr-int2)) |
---|
3350 | (car-int2 |
---|
3351 | (make-cons-ctype car-int2 |
---|
3352 | (type-intersection (cons-ctype-cdr-ctype type1) |
---|
3353 | (cons-ctype-cdr-ctype type2)))) |
---|
3354 | (cdr-int2 |
---|
3355 | (make-cons-ctype (type-intersection (cons-ctype-car-ctype type1) |
---|
3356 | (cons-ctype-car-ctype type2)) |
---|
3357 | cdr-int2))))) |
---|
3358 | |
---|
3359 | |
---|
3360 | ;;; An UNKNOWN-TYPE is a type not known to the type system (not yet defined). |
---|
3361 | ;;; We make this distinction since we don't want to complain about types that |
---|
3362 | ;;; are hairy but defined. |
---|
3363 | ;;; |
---|
3364 | |
---|
3365 | (defun make-unknown-ctype (&key specifier (enumerable t)) |
---|
3366 | (%istruct 'unknown-ctype |
---|
3367 | (type-class-or-lose 'hairy) |
---|
3368 | enumerable |
---|
3369 | specifier)) |
---|
3370 | |
---|
3371 | (defun unknown-ctype-p (x) |
---|
3372 | (istruct-typep x 'unknown-ctype)) |
---|
3373 | |
---|
3374 | (setf (type-predicate 'unknown-ctype) 'unknown-ctype-p) |
---|
3375 | |
---|
3376 | |
---|
3377 | |
---|
3378 | |
---|
3379 | |
---|
3380 | ;;;; foreign-type types |
---|
3381 | |
---|
3382 | |
---|
3383 | (defun %make-foreign-ctype (foreign-type) |
---|
3384 | (%istruct 'foreign-ctype |
---|
3385 | (type-class-or-lose 'foreign) |
---|
3386 | nil |
---|
3387 | foreign-type)) |
---|
3388 | |
---|
3389 | (defun foreign-ctype-p (x) (istruct-typep x 'foreign-ctype)) |
---|
3390 | (setf (type-predicate 'foreign-ctype) 'foreign-ctype-p) |
---|
3391 | |
---|
3392 | (define-type-method (foreign :unparse) (type) |
---|
3393 | `(foreign ,(unparse-foreign-type (foreign-ctype-foreign-type type)))) |
---|
3394 | |
---|
3395 | (define-type-method (foreign :simple-subtypep) (type1 type2) |
---|
3396 | (values (foreign-subtype-p (foreign-ctype-foreign-type type1) |
---|
3397 | (foreign-ctype-foreign-type type2)) |
---|
3398 | t)) |
---|
3399 | |
---|
3400 | ;(define-superclasses foreign (foreign-value)) |
---|
3401 | |
---|
3402 | (define-type-method (foreign :simple-=) (type1 type2) |
---|
3403 | (let ((foreign-type-1 (foreign-ctype-foreign-type type1)) |
---|
3404 | (foreign-type-2 (foreign-ctype-foreign-type type2))) |
---|
3405 | (values (or (eq foreign-type-1 foreign-type-2) |
---|
3406 | (foreign-type-= foreign-type-1 foreign-type-2)) |
---|
3407 | t))) |
---|
3408 | |
---|
3409 | (def-type-translator foreign (&optional (foreign-type nil)) |
---|
3410 | (typecase foreign-type |
---|
3411 | (null |
---|
3412 | (make-foreign-ctype)) |
---|
3413 | (foreign-type |
---|
3414 | (make-foreign-ctype foreign-type)) |
---|
3415 | (t |
---|
3416 | (make-foreign-ctype (parse-foreign-type foreign-type))))) |
---|
3417 | |
---|
3418 | (defun make-foreign-ctype (&optional foreign-type) |
---|
3419 | (if foreign-type |
---|
3420 | (let ((lisp-rep-type (compute-lisp-rep-type foreign-type))) |
---|
3421 | (if lisp-rep-type |
---|
3422 | (specifier-type lisp-rep-type) |
---|
3423 | (%make-foreign-ctype foreign-type))) |
---|
3424 | *universal-type*)) |
---|
3425 | |
---|
3426 | |
---|
3427 | ;;; CLASS-CTYPES are supposed to help integrate CLOS and the CMU type system. |
---|
3428 | ;;; They mostly just contain a backpointer to the CLOS class; the CPL is then |
---|
3429 | ;;; used to resolve type relationships. |
---|
3430 | |
---|
3431 | (defun class-ctype-p (x) (istruct-typep x 'class-ctype)) |
---|
3432 | (setf (type-predicate 'class-ctype) 'class-ctype-p) |
---|
3433 | |
---|
3434 | (defun args-ctype-p (x) (and (eql (typecode x) target::subtag-istruct) |
---|
3435 | (member (istruct-type-name x) |
---|
3436 | '(args-ctype values-ctype function-ctype)))) |
---|
3437 | |
---|
3438 | (setf (type-predicate 'args-ctype) 'args-ctype-p |
---|
3439 | (type-predicate 'function-ctype) 'function-ctype-p |
---|
3440 | (type-predicate 'values-ctype) 'values-ctype-p) |
---|
3441 | |
---|
3442 | |
---|
3443 | ;;; Simple methods for TYPE= and SUBTYPEP should never be called when the two |
---|
3444 | ;;; classes are equal, since there are EQ checks in those operations. |
---|
3445 | ;;; |
---|
3446 | (define-type-method (class :simple-=) (type1 type2) |
---|
3447 | (assert (not (eq type1 type2))) |
---|
3448 | (values nil t)) |
---|
3449 | |
---|
3450 | (define-type-method (class :simple-subtypep) (type1 type2) |
---|
3451 | (assert (not (eq type1 type2))) |
---|
3452 | (let* ((class1 (if (class-ctype-p type1) (class-ctype-class type1))) |
---|
3453 | (class2 (if (class-ctype-p type2) (class-ctype-class type2)))) |
---|
3454 | (if (and class1 class2) |
---|
3455 | (let* ((ordinal2 (%class-ordinal class2)) |
---|
3456 | (wrapper1 (%class.own-wrapper class1)) |
---|
3457 | (bits1 (if wrapper1 (%wrapper-cpl-bits wrapper1)))) |
---|
3458 | (if bits1 |
---|
3459 | (locally (declare (simple-bit-vector bits1) |
---|
3460 | (optimize (speed 3) (safety 0))) |
---|
3461 | (values (if (< ordinal2 (length bits1)) |
---|
3462 | (not (eql 0 (sbit bits1 ordinal2)))) |
---|
3463 | t)) |
---|
3464 | (if (%standard-instance-p class1) |
---|
3465 | (if (memq class2 (%class.local-supers class1)) |
---|
3466 | (values t t) |
---|
3467 | (if (eq (%class-of-instance class1) |
---|
3468 | *forward-referenced-class-class*) |
---|
3469 | (values nil nil) |
---|
3470 | ;; %INITED-CLASS-CPL will return NIL if class1 can't |
---|
3471 | ;; be finalized; in that case, we don't know the answer. |
---|
3472 | (let ((supers (%inited-class-cpl class1))) |
---|
3473 | (if (memq class2 supers) |
---|
3474 | (values t t) |
---|
3475 | (values nil (not (null supers))))))) |
---|
3476 | (values nil t)))) |
---|
3477 | (values nil t)))) |
---|
3478 | |
---|
3479 | (defun find-class-intersection (c1 c2) |
---|
3480 | (labels ((walk-subclasses (class f) |
---|
3481 | (dolist (sub (class-direct-subclasses class)) |
---|
3482 | (walk-subclasses sub f)) |
---|
3483 | (funcall f class))) |
---|
3484 | (let* ((intersection nil)) |
---|
3485 | (walk-subclasses c1 #'(lambda (c) |
---|
3486 | (when (subclassp c c2) |
---|
3487 | (pushnew (%class.ctype c) intersection)))) |
---|
3488 | (when intersection |
---|
3489 | (%type-union intersection))))) |
---|
3490 | |
---|
3491 | (define-type-method (class :simple-intersection) (type1 type2) |
---|
3492 | (assert (not (eq type1 type2))) |
---|
3493 | (let* ((class1 (if (class-ctype-p type1) (class-ctype-class type1))) |
---|
3494 | (class2 (if (class-ctype-p type2) (class-ctype-class type2)))) |
---|
3495 | (if (and class1 |
---|
3496 | (not (typep class1 'compile-time-class)) |
---|
3497 | class2 |
---|
3498 | (not (typep class2 'compile-time-class))) |
---|
3499 | (cond ((subclassp class1 class2) |
---|
3500 | type1) |
---|
3501 | ((subclassp class2 class1) |
---|
3502 | type2) |
---|
3503 | ;;; In the STANDARD-CLASS case where neither's |
---|
3504 | ;;; a subclass of the other, there may be |
---|
3505 | ;;; one or mor classes that're a subclass of both. We |
---|
3506 | ;;; -could- try to find all such classes, but |
---|
3507 | ;;; punt instead. |
---|
3508 | (t (or (find-class-intersection class1 class2) |
---|
3509 | *empty-type*))) |
---|
3510 | nil))) |
---|
3511 | |
---|
3512 | (define-type-method (class :complex-subtypep-arg2) (type1 class2) |
---|
3513 | (if (and (intersection-ctype-p type1) |
---|
3514 | (> (count-if #'class-ctype-p (intersection-ctype-types type1)) 1)) |
---|
3515 | (values nil nil) |
---|
3516 | (invoke-complex-subtypep-arg1-method type1 class2 nil t))) |
---|
3517 | |
---|
3518 | (define-type-method (class :complex-subtypep-arg1) (type1 type2) |
---|
3519 | (if (and (function-ctype-p type2) |
---|
3520 | (eq type1 (specifier-type 'function)) |
---|
3521 | (function-ctype-wild-args type2) |
---|
3522 | (eq *wild-type* (function-ctype-returns type2))) |
---|
3523 | (values t t) |
---|
3524 | (values nil t))) |
---|
3525 | |
---|
3526 | (define-type-method (class :unparse) (type) |
---|
3527 | (class-name (class-ctype-class type))) |
---|
3528 | |
---|
3529 | |
---|
3530 | ;;; TYPE-DIFFERENCE -- Interface |
---|
3531 | ;;; |
---|
3532 | ;;; Return the type that describes all objects that are in X but not in Y. |
---|
3533 | ;;; If we can't determine this type, then return NIL. |
---|
3534 | ;;; |
---|
3535 | ;;; For now, we only are clever dealing with union and member types. If |
---|
3536 | ;;; either type is not a union type, then we pretend that it is a union of just |
---|
3537 | ;;; one type. What we do is remove from X all the types that are a subtype any |
---|
3538 | ;;; type in Y. If any type in X intersects with a type in Y but is not a |
---|
3539 | ;;; subtype, then we give up. |
---|
3540 | ;;; |
---|
3541 | ;;; We must also special-case any member type that appears in the union. We |
---|
3542 | ;;; remove from X's members all objects that are TYPEP to Y. If Y has any |
---|
3543 | ;;; members, we must be careful that none of those members are CTYPEP to any |
---|
3544 | ;;; of Y's non-member types. We give up in this case, since to compute that |
---|
3545 | ;;; difference we would have to break the type from X into some collection of |
---|
3546 | ;;; types that represents the type without that particular element. This seems |
---|
3547 | ;;; too hairy to be worthwhile, given its low utility. |
---|
3548 | ;;; |
---|
3549 | (defun type-difference (x y) |
---|
3550 | (let ((x-types (if (union-ctype-p x) (union-ctype-types x) (list x))) |
---|
3551 | (y-types (if (union-ctype-p y) (union-ctype-types y) (list y)))) |
---|
3552 | (collect ((res)) |
---|
3553 | (dolist (x-type x-types) |
---|
3554 | (if (member-ctype-p x-type) |
---|
3555 | (collect ((members)) |
---|
3556 | (dolist (mem (member-ctype-members x-type)) |
---|
3557 | (multiple-value-bind (val win) (ctypep mem y) |
---|
3558 | (unless win (return-from type-difference nil)) |
---|
3559 | (unless val |
---|
3560 | (members mem)))) |
---|
3561 | (when (members) |
---|
3562 | (res (make-member-ctype :members (members))))) |
---|
3563 | (dolist (y-type y-types (res x-type)) |
---|
3564 | (multiple-value-bind (val win) (csubtypep x-type y-type) |
---|
3565 | (unless win (return-from type-difference nil)) |
---|
3566 | (when val (return)) |
---|
3567 | (when (types-intersect x-type y-type) |
---|
3568 | (return-from type-difference nil)))))) |
---|
3569 | (let ((y-mem (find-if #'member-ctype-p y-types))) |
---|
3570 | (when y-mem |
---|
3571 | (let ((members (member-ctype-members y-mem))) |
---|
3572 | (dolist (x-type x-types) |
---|
3573 | (unless (member-ctype-p x-type) |
---|
3574 | (dolist (member members) |
---|
3575 | (multiple-value-bind (val win) (ctypep member x-type) |
---|
3576 | (when (or (not win) val) |
---|
3577 | (return-from type-difference nil))))))))) |
---|
3578 | (apply #'type-union (res))))) |
---|
3579 | |
---|
3580 | ;;; CTypep -- Interface |
---|
3581 | ;;; |
---|
3582 | ;;; If Type is a type that we can do a compile-time test on, then return the |
---|
3583 | ;;; whether the object is of that type as the first value and second value |
---|
3584 | ;;; true. Otherwise return NIL, NIL. |
---|
3585 | ;;; |
---|
3586 | ;;; We give up on unknown types, pick off FUNCTION and UNION types. For |
---|
3587 | ;;; structure types, we require that the type be defined in both the current |
---|
3588 | ;;; and compiler environments, and that the INCLUDES be the same. |
---|
3589 | ;;; |
---|
3590 | (defun ctypep (obj type) |
---|
3591 | (declare (type ctype type)) |
---|
3592 | (etypecase type |
---|
3593 | ((or numeric-ctype named-ctype member-ctype array-ctype cons-ctype) |
---|
3594 | (values (%typep obj type) t)) |
---|
3595 | (class-ctype |
---|
3596 | (values (not (null (class-typep obj (class-ctype-class type)))) t) |
---|
3597 | ) |
---|
3598 | (union-ctype |
---|
3599 | (any/type #'ctypep obj (union-ctype-types type))) |
---|
3600 | (intersection-ctype |
---|
3601 | (every/type #'ctypep obj (intersection-ctype-types type))) |
---|
3602 | (function-ctype |
---|
3603 | (values (functionp obj) t)) |
---|
3604 | (unknown-ctype |
---|
3605 | (values nil nil)) |
---|
3606 | (foreign-ctype |
---|
3607 | (values (foreign-typep obj (foreign-ctype-foreign-type type)) t)) |
---|
3608 | (negation-ctype |
---|
3609 | (multiple-value-bind (res win) |
---|
3610 | (ctypep obj (negation-ctype-type type)) |
---|
3611 | (if win |
---|
3612 | (values (not res) t) |
---|
3613 | (values nil nil)))) |
---|
3614 | (hairy-ctype |
---|
3615 | ;; Now the tricky stuff. |
---|
3616 | (let* ((hairy-spec (hairy-ctype-specifier type)) |
---|
3617 | (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) |
---|
3618 | (ecase symbol |
---|
3619 | (and ; how would this get there ? |
---|
3620 | (if (atom hairy-spec) |
---|
3621 | (values t t) |
---|
3622 | (dolist (spec (cdr hairy-spec) (values t t)) |
---|
3623 | (multiple-value-bind (res win) |
---|
3624 | (ctypep obj (specifier-type spec)) |
---|
3625 | (unless win (return (values nil nil))) |
---|
3626 | (unless res (return (values nil t))))))) |
---|
3627 | (not ; how would this get there ? |
---|
3628 | (multiple-value-bind |
---|
3629 | (res win) |
---|
3630 | (ctypep obj (specifier-type (cadr hairy-spec))) |
---|
3631 | (if win |
---|
3632 | (values (not res) t) |
---|
3633 | (values nil nil)))) |
---|
3634 | (satisfies |
---|
3635 | (let ((fun (second hairy-spec))) |
---|
3636 | (cond ((and (symbolp fun) (fboundp fun)) |
---|
3637 | ;; Binding *BREAK-ON-SIGNALS* here is a modularity |
---|
3638 | ;; violation intended to improve the signal-to-noise |
---|
3639 | ;; ratio on a mailing list. |
---|
3640 | (values (not (null (let* ((*break-on-signals* nil)) |
---|
3641 | (ignore-errors (funcall fun obj))))) t)) |
---|
3642 | (t |
---|
3643 | (values nil nil)))))))))) |
---|
3644 | |
---|
3645 | ;;; %TYPEP -- internal. |
---|
3646 | ;;; |
---|
3647 | ;;; The actual typep engine. The compiler only generates calls to this |
---|
3648 | ;;; function when it can't figure out anything more intelligent to do. |
---|
3649 | ;;; |
---|
3650 | ; lose 1 function call -MAYBE |
---|
3651 | (defun %typep (object specifier) |
---|
3652 | (%%typep object |
---|
3653 | (if (typep specifier 'ctype) |
---|
3654 | specifier |
---|
3655 | (specifier-type specifier)))) |
---|
3656 | |
---|
3657 | (eval-when (:compile-toplevel) |
---|
3658 | (declaim (inline numeric-%%typep |
---|
3659 | array-%%typep |
---|
3660 | member-%%typep |
---|
3661 | cons-%%typep))) |
---|
3662 | |
---|
3663 | (defun numeric-%%typep (object type) |
---|
3664 | (let ((pred (numeric-ctype-predicate type))) |
---|
3665 | (if pred |
---|
3666 | (funcall pred object) |
---|
3667 | (and (numberp object) |
---|
3668 | (let ((num (if (complexp object) (realpart object) object))) |
---|
3669 | (ecase (numeric-ctype-class type) |
---|
3670 | (integer (integerp num)) |
---|
3671 | (rational (rationalp num)) |
---|
3672 | (float |
---|
3673 | (ecase (numeric-ctype-format type) |
---|
3674 | (single-float (typep num 'single-float)) |
---|
3675 | (double-float (typep num 'double-float)) |
---|
3676 | ((nil) (floatp num)))) |
---|
3677 | ((nil) t))) |
---|
3678 | (flet ((bound-test (val) |
---|
3679 | (let ((low (numeric-ctype-low type)) |
---|
3680 | (high (numeric-ctype-high type))) |
---|
3681 | (and (cond ((null low) t) |
---|
3682 | ((listp low) (> val (car low))) |
---|
3683 | (t (>= val low))) |
---|
3684 | (cond ((null high) t) |
---|
3685 | ((listp high) (< val (car high))) |
---|
3686 | (t (<= val high))))))) |
---|
3687 | (ecase (numeric-ctype-complexp type) |
---|
3688 | ((nil) t) |
---|
3689 | (:complex |
---|
3690 | (and (complexp object) |
---|
3691 | (bound-test (realpart object)) |
---|
3692 | (bound-test (imagpart object)))) |
---|
3693 | (:real |
---|
3694 | (and (not (complexp object)) |
---|
3695 | (bound-test object))))))))) |
---|
3696 | |
---|
3697 | (defun array-%%typep (object type) |
---|
3698 | (let* ((typecode (typecode object))) |
---|
3699 | (declare (type (unsigned-byte 8) typecode)) |
---|
3700 | (and (>= typecode target::subtag-arrayH) |
---|
3701 | (ecase (array-ctype-complexp type) |
---|
3702 | ((t) (not (simple-array-p object))) |
---|
3703 | ((nil) (simple-array-p object)) |
---|
3704 | ((* :maybe) t)) |
---|
3705 | (let* ((ctype-dimensions (array-ctype-dimensions type))) |
---|
3706 | (or (eq ctype-dimensions '*) |
---|
3707 | (if (eql typecode target::subtag-arrayH) |
---|
3708 | (let* ((rank (%svref object target::arrayH.rank-cell))) |
---|
3709 | (declare (fixnum rank)) |
---|
3710 | (and (eql rank (length ctype-dimensions)) |
---|
3711 | (do* ((i 0 (1+ i)) |
---|
3712 | (dim target::arrayH.dim0-cell (1+ dim)) |
---|
3713 | (want (array-ctype-dimensions type) (cdr want)) |
---|
3714 | (got (%svref object dim) (%svref object dim))) |
---|
3715 | ((eql i rank) t) |
---|
3716 | (unless (or (eq (car want) '*) |
---|
3717 | (eql (%car want) (the fixnum got))) |
---|
3718 | (return nil))))) |
---|
3719 | (and (null (cdr ctype-dimensions)) |
---|
3720 | (or (eq (%car ctype-dimensions) '*) |
---|
3721 | (eql (%car ctype-dimensions) |
---|
3722 | (if (eql typecode target::subtag-vectorH) |
---|
3723 | (%svref object target::vectorH.physsize-cell) |
---|
3724 | (uvsize object)))))))) |
---|
3725 | (or (eq (array-ctype-element-type type) *wild-type*) |
---|
3726 | (eql (array-ctype-typecode type) |
---|
3727 | (if (> typecode target::subtag-vectorH) |
---|
3728 | typecode |
---|
3729 | (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref object target::arrayH.flags-cell))))) |
---|
3730 | (type= (array-ctype-specialized-element-type type) |
---|
3731 | (specifier-type (array-element-type object))))))) |
---|
3732 | |
---|
3733 | |
---|
3734 | (defun member-%%typep (object type) |
---|
3735 | (not (null (member object (member-ctype-members type))))) |
---|
3736 | |
---|
3737 | (defun cons-%%typep (object type) |
---|
3738 | (and (consp object) |
---|
3739 | (%%typep (car object) (cons-ctype-car-ctype type)) |
---|
3740 | (%%typep (cdr object) (cons-ctype-cdr-ctype type)))) |
---|
3741 | |
---|
3742 | |
---|
3743 | (defun %%typep (object type) |
---|
3744 | ;(if (not (typep type 'ctype))(setq type (specifier-type type))) |
---|
3745 | (locally (declare (type ctype type)) |
---|
3746 | (etypecase type |
---|
3747 | (named-ctype |
---|
3748 | (ecase (named-ctype-name type) |
---|
3749 | ((* t) t) |
---|
3750 | ((nil) nil))) |
---|
3751 | (numeric-ctype |
---|
3752 | (numeric-%%typep object type)) |
---|
3753 | (array-ctype |
---|
3754 | (array-%%typep object type)) |
---|
3755 | (member-ctype |
---|
3756 | (member-%%typep object type)) |
---|
3757 | (class-ctype |
---|
3758 | (not (null (class-typep object (class-ctype-class type))))) |
---|
3759 | (union-ctype |
---|
3760 | (dolist (type (union-ctype-types type)) |
---|
3761 | (when (%%typep object type) |
---|
3762 | (return t)))) |
---|
3763 | (intersection-ctype |
---|
3764 | (dolist (type (intersection-ctype-types type) t) |
---|
3765 | (unless (%%typep object type) (return nil)))) |
---|
3766 | (cons-ctype |
---|
3767 | (cons-%%typep object type)) |
---|
3768 | (unknown-ctype |
---|
3769 | ;; Parse it again to make sure it's really undefined. |
---|
3770 | (let ((reparse (specifier-type (unknown-ctype-specifier type)))) |
---|
3771 | (if (typep reparse 'unknown-ctype) |
---|
3772 | (error "Unknown type specifier: ~S" |
---|
3773 | (unknown-ctype-specifier reparse)) |
---|
3774 | (%%typep object reparse)))) |
---|
3775 | (negation-ctype |
---|
3776 | (not (%%typep object (negation-ctype-type type)))) |
---|
3777 | (hairy-ctype |
---|
3778 | ;; Now the tricky stuff. |
---|
3779 | (let* ((hairy-spec (hairy-ctype-specifier type)) |
---|
3780 | (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) |
---|
3781 | (ecase symbol |
---|
3782 | (and |
---|
3783 | (or (atom hairy-spec) |
---|
3784 | (dolist (spec (cdr hairy-spec) t) |
---|
3785 | (unless (%%typep object (specifier-type spec)) |
---|
3786 | (return nil))))) |
---|
3787 | (not |
---|
3788 | (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) |
---|
3789 | (error "Invalid type specifier: ~S" hairy-spec)) |
---|
3790 | (not (%%typep object (specifier-type (cadr hairy-spec))))) |
---|
3791 | (satisfies |
---|
3792 | (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) |
---|
3793 | (error "Invalid type specifier: ~S" hairy-spec)) |
---|
3794 | (let ((fn (cadr hairy-spec))) |
---|
3795 | (if (funcall (typecase fn |
---|
3796 | (function fn) |
---|
3797 | (symbol (symbol-function fn)) |
---|
3798 | (t |
---|
3799 | (coerce fn 'function))) |
---|
3800 | object) |
---|
3801 | t |
---|
3802 | nil)))))) |
---|
3803 | #| |
---|
3804 | (foreign-ctype |
---|
3805 | (foreign-typep object (foreign-ctype-foreign-type type))) |
---|
3806 | |# |
---|
3807 | (function-ctype |
---|
3808 | (error "Function types are not a legal argument to TYPEP:~% ~S" |
---|
3809 | (type-specifier type)))))) |
---|
3810 | |
---|
3811 | |
---|
3812 | ;;; Ctype-Of -- Interface |
---|
3813 | ;;; |
---|
3814 | ;;; Like Type-Of, only returns a Type structure instead of a type |
---|
3815 | ;;; specifier. We try to return the type most useful for type checking, rather |
---|
3816 | ;;; than trying to come up with the one that the user might find most |
---|
3817 | ;;; informative. |
---|
3818 | ;;; |
---|
3819 | |
---|
3820 | (defun float-format-name (x) |
---|
3821 | (declare (float x)) |
---|
3822 | (etypecase x |
---|
3823 | (single-float "SINGLE-FLOAT") |
---|
3824 | (double-float "DOUBLE-FLOAT"))) |
---|
3825 | |
---|
3826 | (defun ctype-of-number (x) |
---|
3827 | (let ((num (if (complexp x) (realpart x) x))) |
---|
3828 | (multiple-value-bind (complexp low high) |
---|
3829 | (if (complexp x) |
---|
3830 | (let ((imag (imagpart x))) |
---|
3831 | (values :complex (min num imag) (max num imag))) |
---|
3832 | (values :real num num)) |
---|
3833 | (make-numeric-ctype :class (etypecase num |
---|
3834 | (integer (if (complexp x) |
---|
3835 | (if (integerp (imagpart x)) |
---|
3836 | 'integer |
---|
3837 | 'rational) |
---|
3838 | 'integer)) |
---|
3839 | (rational 'rational) |
---|
3840 | (float 'float)) |
---|
3841 | :format (and (floatp num) |
---|
3842 | (if (typep num 'double-float) |
---|
3843 | 'double-float |
---|
3844 | 'single-float)) |
---|
3845 | :complexp complexp |
---|
3846 | :low low |
---|
3847 | :high high)))) |
---|
3848 | |
---|
3849 | (defun ctype-of (x) |
---|
3850 | (typecase x |
---|
3851 | (function (specifier-type 'function)) ; GFs .. |
---|
3852 | (symbol |
---|
3853 | (make-member-ctype :members (list x))) |
---|
3854 | (number (ctype-of-number x)) |
---|
3855 | (array |
---|
3856 | (let ((etype (specifier-type (array-element-type x)))) |
---|
3857 | (make-array-ctype :dimensions (array-dimensions x) |
---|
3858 | :complexp (not (typep x 'simple-array)) |
---|
3859 | :element-type etype |
---|
3860 | :specialized-element-type etype))) |
---|
3861 | (t |
---|
3862 | (%class.ctype (class-of x))))) |
---|
3863 | |
---|
3864 | (defvar *ctype-of-double-float-0* (ctype-of 0.0d0)) |
---|
3865 | (defvar *ctype-of-single-float-0* (ctype-of 0.0f0)) |
---|
3866 | |
---|
3867 | |
---|
3868 | |
---|
3869 | |
---|
3870 | ; These DEFTYPES should only happen while initializing. |
---|
3871 | |
---|
3872 | (progn |
---|
3873 | (let-globally ((*type-system-initialized* nil)) |
---|
3874 | |
---|
3875 | |
---|
3876 | (deftype bit () '(integer 0 1)) |
---|
3877 | |
---|
3878 | (deftype eql (val) `(member ,val)) |
---|
3879 | |
---|
3880 | (deftype signed-byte (&optional s) |
---|
3881 | (cond ((eq s '*) 'integer) |
---|
3882 | ((and (integerp s) (> s 0)) |
---|
3883 | (let ((bound (ash 1 (1- s)))) |
---|
3884 | `(integer ,(- bound) ,(1- bound)))) |
---|
3885 | (t |
---|
3886 | (signal-program-error "Bad size specified for SIGNED-BYTE type specifier: ~S." s)))) |
---|
3887 | |
---|
3888 | (deftype unsigned-byte (&optional s) |
---|
3889 | (cond ((eq s '*) '(integer 0)) |
---|
3890 | ((and (integerp s) (> s 0)) |
---|
3891 | `(integer 0 ,(1- (ash 1 s)))) |
---|
3892 | (t |
---|
3893 | (error "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s)))) |
---|
3894 | |
---|
3895 | (deftype vector (&optional element-type size) |
---|
3896 | `(array ,element-type (,size))) |
---|
3897 | |
---|
3898 | (deftype simple-vector (&optional size) |
---|
3899 | `(simple-array t (,size))) |
---|
3900 | |
---|
3901 | (deftype base-string (&optional size) |
---|
3902 | `(array base-char (,size))) |
---|
3903 | (deftype simple-base-string (&optional size) |
---|
3904 | `(simple-array base-char (,size))) |
---|
3905 | |
---|
3906 | |
---|
3907 | |
---|
3908 | (deftype string (&optional size) |
---|
3909 | `(array character (,size))) |
---|
3910 | |
---|
3911 | (deftype simple-string (&optional size) |
---|
3912 | `(simple-array character (,size))) |
---|
3913 | |
---|
3914 | (deftype extended-string (&optional size) |
---|
3915 | (declare (ignore size)) |
---|
3916 | 'nil) |
---|
3917 | |
---|
3918 | (deftype simple-extended-string (&optional size) |
---|
3919 | (declare (ignore size)) |
---|
3920 | 'nil) |
---|
3921 | |
---|
3922 | (deftype bit-vector (&optional size) |
---|
3923 | `(array bit (,size))) |
---|
3924 | |
---|
3925 | (deftype simple-bit-vector (&optional size) |
---|
3926 | `(simple-array bit (,size))) |
---|
3927 | |
---|
3928 | ; TYPE-OF sometimes returns random symbols that aren't really type specifiers. |
---|
3929 | |
---|
3930 | (deftype simple-unsigned-word-vector (&optional size) |
---|
3931 | `(simple-array (unsigned-byte 16) (,size))) |
---|
3932 | |
---|
3933 | (deftype simple-unsigned-byte-vector (&optional size) |
---|
3934 | `(simple-array (unsigned-byte 8) (,size))) |
---|
3935 | |
---|
3936 | (deftype simple-unsigned-long-vector (&optional size) |
---|
3937 | `(simple-array (unsigned-byte 32) (,size))) |
---|
3938 | |
---|
3939 | (deftype simple-signed-word-vector (&optional size) |
---|
3940 | `(simple-array (signed-byte 16) (,size))) |
---|
3941 | |
---|
3942 | (deftype simple-signed-byte-vector (&optional size) |
---|
3943 | `(simple-array (signed-byte 8) (,size))) |
---|
3944 | |
---|
3945 | (deftype simple-signed-long-vector (&optional size) |
---|
3946 | `(simple-array (signed-byte 32) (,size))) |
---|
3947 | |
---|
3948 | (deftype simple-double-float-vector (&optional size) |
---|
3949 | `(simple-array double-float (,size))) |
---|
3950 | |
---|
3951 | (deftype simple-short-float-vector (&optional size) |
---|
3952 | `(simple-array short-float (,size))) |
---|
3953 | |
---|
3954 | (deftype unsigned-word-vector (&optional size) |
---|
3955 | `(vector (unsigned-byte 16) ,size)) |
---|
3956 | |
---|
3957 | (deftype single-float-vector (&optional size) |
---|
3958 | `(vector short-float ,size)) |
---|
3959 | |
---|
3960 | (deftype unsigned-byte-vector (&optional size) |
---|
3961 | `(vector (unsigned-byte 8) ,size)) |
---|
3962 | |
---|
3963 | (deftype unsigned-long-vector (&optional size) |
---|
3964 | `(vector (unsigned-byte 32) ,size)) |
---|
3965 | |
---|
3966 | (deftype long-float-vector (&optional size) |
---|
3967 | `(vector double-float ,size)) |
---|
3968 | |
---|
3969 | (deftype long-vector (&optional size) |
---|
3970 | `(vector (signed-byte 32) ,size)) |
---|
3971 | |
---|
3972 | (deftype double-float-vector (&optional size) |
---|
3973 | `(vector double-float ,size)) |
---|
3974 | |
---|
3975 | (deftype byte-vector (&optional size) |
---|
3976 | `(vector (signed-byte 8) ,size)) |
---|
3977 | |
---|
3978 | (deftype general-vector (&optional size) |
---|
3979 | `(vector t ,size)) |
---|
3980 | |
---|
3981 | (deftype word-vector (&optional size) |
---|
3982 | `(vector (signed-byte 16) ,size)) |
---|
3983 | |
---|
3984 | (deftype short-float-vector (&optional size) |
---|
3985 | `(vector single-float ,size)) |
---|
3986 | |
---|
3987 | (deftype simple-1d-array (&optional size) |
---|
3988 | `(simple-array * (,size))) |
---|
3989 | |
---|
3990 | (deftype simple-long-vector (&optional size) |
---|
3991 | `(simple-array (signed-byte 32) (,size))) |
---|
3992 | |
---|
3993 | (deftype simple-word-vector (&optional size) |
---|
3994 | `(simple-array (signed-byte 16) (,size))) |
---|
3995 | |
---|
3996 | (deftype simple-short-float-vector (&optional size) |
---|
3997 | `(simple-array single-float (,size))) |
---|
3998 | |
---|
3999 | (deftype simple-byte-vector (&optional size) |
---|
4000 | `(simple-array (signed-byte 8) (,size))) |
---|
4001 | |
---|
4002 | (deftype simple-double-float-vector (&optional size) |
---|
4003 | `(simple-array double-float (,size))) |
---|
4004 | |
---|
4005 | (deftype simple-single-float-vector (&optional size) |
---|
4006 | `(simple-array single-float (,size))) |
---|
4007 | |
---|
4008 | (deftype simple-fixnum-vector (&optional size) |
---|
4009 | `(simple-array fixnum (,size))) |
---|
4010 | |
---|
4011 | #+64-bit-target |
---|
4012 | (deftype simple-doubleword-vector (&optional size) |
---|
4013 | `(simple-array (signed-byte 64) (,size))) |
---|
4014 | |
---|
4015 | #+64-bit-target |
---|
4016 | (deftype simple-unsigned-doubleword-vector (&optional size) |
---|
4017 | `(simple-array (unsigned-byte 64) (,size))) |
---|
4018 | |
---|
4019 | |
---|
4020 | (deftype short-float (&optional low high) |
---|
4021 | `(single-float ,low ,high)) |
---|
4022 | |
---|
4023 | (deftype long-float (&optional low high) |
---|
4024 | `(double-float ,low ,high)) |
---|
4025 | |
---|
4026 | ;;; As empty a type as you're likely to find ... |
---|
4027 | (deftype extended-char () |
---|
4028 | "Type of CHARACTERs that aren't BASE-CHARs." |
---|
4029 | nil) |
---|
4030 | |
---|
4031 | (deftype natural () |
---|
4032 | `(unsigned-byte ,target::nbits-in-word)) |
---|
4033 | |
---|
4034 | (deftype signed-natural () |
---|
4035 | `(signed-byte ,target::nbits-in-word)) |
---|
4036 | ) |
---|
4037 | |
---|
4038 | |
---|
4039 | (let* ((builtin-translations |
---|
4040 | `((array . array) |
---|
4041 | (simple-array . simple-array) |
---|
4042 | (cons . cons) |
---|
4043 | (vector . vector) |
---|
4044 | (null . (member nil)) |
---|
4045 | (list . (or cons null)) |
---|
4046 | (sequence . (or list vector)) |
---|
4047 | (simple-vector . simple-vector) |
---|
4048 | (bit-vector . bit-vector) |
---|
4049 | (simple-bit-vector . simple-bit-vector) |
---|
4050 | (simple-string . simple-string) |
---|
4051 | (simple-base-string . simple-base-string) |
---|
4052 | (string . string) |
---|
4053 | (base-string . base-string) |
---|
4054 | (real . real) |
---|
4055 | (complex . complex) |
---|
4056 | (float . float) |
---|
4057 | (double-float . double-float) |
---|
4058 | (long-float . double-float) |
---|
4059 | (single-float . single-float) |
---|
4060 | (short-float . single-float) |
---|
4061 | |
---|
4062 | (rational . rational) |
---|
4063 | (integer . integer) |
---|
4064 | (ratio . (and rational (not integer))) |
---|
4065 | (fixnum . (integer ,target::target-most-negative-fixnum |
---|
4066 | ,target::target-most-positive-fixnum)) |
---|
4067 | (bignum . (or (integer * (,target::target-most-negative-fixnum)) |
---|
4068 | (integer (,target::target-most-positive-fixnum) *))) |
---|
4069 | |
---|
4070 | ))) |
---|
4071 | (dolist (spec builtin-translations) |
---|
4072 | (setf (info-type-kind (car spec)) :primitive |
---|
4073 | (info-type-builtin (car spec)) (specifier-type (cdr spec))))) |
---|
4074 | |
---|
4075 | |
---|
4076 | |
---|
4077 | |
---|
4078 | |
---|
4079 | |
---|
4080 | (precompute-types '((mod 2) (mod 4) (mod 16) (mod #x100) (mod #x10000) |
---|
4081 | #-cross-compiling |
---|
4082 | (mod #x100000000) |
---|
4083 | (unsigned-byte 1) |
---|
4084 | (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) |
---|
4085 | (unsigned-byte 64) |
---|
4086 | (signed-byte 8) (signed-byte 16) (signed-byte 32) |
---|
4087 | (signed-byte 64) |
---|
4088 | (or function symbol) |
---|
4089 | )) |
---|
4090 | |
---|
4091 | |
---|
4092 | (precompute-types *cl-types*) |
---|
4093 | |
---|
4094 | ;;; Treat CHARACTER and BASE-CHAR as equivalent. |
---|
4095 | (setf (info-type-builtin 'character) (info-type-builtin 'base-char)) |
---|
4096 | ;;; And EXTENDED-CHAR as empty. |
---|
4097 | (setf (info-type-builtin 'extended-char) *empty-type*) |
---|
4098 | |
---|
4099 | (defparameter *null-type* (specifier-type 'null)) |
---|
4100 | |
---|
4101 | |
---|
4102 | (flet ((set-builtin-class-type-translation (thing) |
---|
4103 | (let* ((class-name (if (atom thing) thing (car thing))) |
---|
4104 | (spec (if (atom thing) thing (cadr thing))) |
---|
4105 | (spectype (specifier-type spec))) |
---|
4106 | (setf (class-ctype-translation |
---|
4107 | (%class.ctype (find-class class-name))) spectype)))) |
---|
4108 | (mapc #'set-builtin-class-type-translation |
---|
4109 | '( |
---|
4110 | ;; Root Of All Evil |
---|
4111 | t |
---|
4112 | ;; Numbers: |
---|
4113 | number real ratio complex rational fixnum |
---|
4114 | ;; Integers: |
---|
4115 | signed-byte unsigned-byte bit bignum integer |
---|
4116 | ;; Floats |
---|
4117 | float double-float single-float |
---|
4118 | ;; Arrays |
---|
4119 | array |
---|
4120 | ;; Simple Arrays |
---|
4121 | simple-array |
---|
4122 | ;; Vectors |
---|
4123 | vector string base-string bit-vector |
---|
4124 | unsigned-byte-vector unsigned-word-vector unsigned-long-vector |
---|
4125 | byte-vector word-vector long-vector |
---|
4126 | single-float-vector double-float-vector |
---|
4127 | general-vector |
---|
4128 | fixnum-vector |
---|
4129 | #+64-bit-target |
---|
4130 | doubleword-vector |
---|
4131 | #+64-bit-target |
---|
4132 | unsigned-doubleword-vector |
---|
4133 | ;; Simple 1-Dimensional Arrays |
---|
4134 | simple-1d-array simple-string simple-base-string simple-bit-vector |
---|
4135 | simple-unsigned-byte-vector |
---|
4136 | simple-unsigned-long-vector |
---|
4137 | simple-unsigned-word-vector |
---|
4138 | simple-byte-vector |
---|
4139 | simple-word-vector |
---|
4140 | simple-long-vector |
---|
4141 | simple-single-float-vector |
---|
4142 | simple-double-float-vector |
---|
4143 | simple-vector |
---|
4144 | simple-fixnum-vector |
---|
4145 | #+64-bit-target |
---|
4146 | simple-doubleword-vector |
---|
4147 | #+64-bit-target |
---|
4148 | simple-unsigned-doubleword-vector |
---|
4149 | ;; Sequence types |
---|
4150 | sequence list cons null |
---|
4151 | |
---|
4152 | ) |
---|
4153 | |
---|
4154 | )) |
---|
4155 | ) |
---|
4156 | ;(setq *type-system-initialized* t) |
---|
4157 | |
---|
4158 | |
---|
4159 | |
---|
4160 | |
---|
4161 | ; These deftypes help the CMUCL compiler; the type system doesn't depend on them. |
---|
4162 | |
---|
4163 | ;;; Since OpenMCL's DEFTYPE tries to globally define the type |
---|
4164 | ;;; at compile-time as well as load- and execute time, hide |
---|
4165 | ;;; the definition of these "built-in" types. (It'd be cleaner |
---|
4166 | ;;; to make DEFTYPE do something saner at compile-time.) |
---|
4167 | (let* () ; make the following be non-toplevel |
---|
4168 | (deftype boolean () '(member t nil)) |
---|
4169 | |
---|
4170 | (deftype atom () '(not cons)) |
---|
4171 | ;;; |
---|
4172 | ;;; A type specifier. |
---|
4173 | (deftype type-specifier () '(or list symbol class)) |
---|
4174 | ;;; |
---|
4175 | ;;; An index into an array. Also used for sequence index. |
---|
4176 | (deftype index () `(integer 0 (,array-dimension-limit))) |
---|
4177 | ;;; |
---|
4178 | ;;; Array rank, total size... |
---|
4179 | (deftype array-rank () `(integer 0 (,array-rank-limit))) |
---|
4180 | (deftype array-total-size () `(integer 0 (,array-total-size-limit))) |
---|
4181 | ;;; |
---|
4182 | ;;; Some thing legal in an evaluated context. |
---|
4183 | (deftype form () t) |
---|
4184 | ;;; |
---|
4185 | ;;; Maclisp compatibility... |
---|
4186 | (deftype stringlike () '(or string symbol)) |
---|
4187 | (deftype stringable () '(or string symbol character)) |
---|
4188 | ;;; |
---|
4189 | ;;; Save a little typing... |
---|
4190 | (deftype truth () '(member t)) |
---|
4191 | ;;; |
---|
4192 | ;;; A thing legal in places where we want the name of a file. |
---|
4193 | (deftype filename () '(or string pathname)) |
---|
4194 | ;;; |
---|
4195 | ;;; A legal arg to pathname functions. |
---|
4196 | (deftype pathnamelike () '(or string pathname stream)) |
---|
4197 | ;;; |
---|
4198 | ;;; A thing returned by the irrational functions. We assume that they never |
---|
4199 | ;;; compute a rational result. |
---|
4200 | (deftype irrational () '(or float (complex float))) |
---|
4201 | ;;; |
---|
4202 | ;;; Character components: |
---|
4203 | (deftype char-code () `(integer 0 (,char-code-limit))) |
---|
4204 | ;;; |
---|
4205 | ;;; A consed sequence result. If a vector, is a simple array. |
---|
4206 | (deftype consed-sequence () '(or list (simple-array * (*)))) |
---|
4207 | ;;; |
---|
4208 | ;;; The :end arg to a sequence... |
---|
4209 | (deftype sequence-end () '(or null index)) |
---|
4210 | ;;; |
---|
4211 | ;;; A valid argument to a stream function... |
---|
4212 | (deftype streamlike () '(or stream (member nil t))) |
---|
4213 | ;;; |
---|
4214 | ;;; A thing that can be passed to funcall & friends. |
---|
4215 | (deftype callable () '(or function symbol)) |
---|
4216 | |
---|
4217 | ;;; Until we decide if and how to wedge this into the type system, make it |
---|
4218 | ;;; equivalent to t. |
---|
4219 | ;;; |
---|
4220 | (deftype void () t) |
---|
4221 | ;;; |
---|
4222 | ;;; An index into an integer. |
---|
4223 | (deftype bit-index () `(integer 0 ,target::target-most-positive-fixnum)) |
---|
4224 | ;;; |
---|
4225 | ;;; Offset argument to Ash (a signed bit index). |
---|
4226 | (deftype ash-index () 'fixnum) |
---|
4227 | |
---|
4228 | ;;; Not sure how to do this without SATISFIES. |
---|
4229 | (deftype setf-function-name () `(satisfies setf-function-name-p)) |
---|
4230 | |
---|
4231 | ;;; Better than nothing, arguably. |
---|
4232 | (deftype function-name () `(or symbol setf-function-name)) |
---|
4233 | |
---|
4234 | (deftype valid-char-code () `(satisfies valid-char-code-p)) |
---|
4235 | |
---|
4236 | ) ; end of LET* sleaze |
---|
4237 | |
---|
4238 | (defun array-or-union-ctype-element-type (ctype) |
---|
4239 | (if (typep ctype 'array-ctype) |
---|
4240 | (type-specifier (array-ctype-element-type ctype)) |
---|
4241 | (if (typep ctype 'union-ctype) |
---|
4242 | `(or ,@(mapcar #'array-or-union-ctype-element-type |
---|
4243 | (union-ctype-types ctype)))))) |
---|
4244 | |
---|
4245 | |
---|
4246 | (defvar *simple-predicate-function-prototype* |
---|
4247 | #'(lambda (thing) |
---|
4248 | (%%typep thing #.(specifier-type t)))) |
---|
4249 | |
---|
4250 | (defun make-simple-type-predicate (function datum) |
---|
4251 | #+ppc-target |
---|
4252 | (gvector :function |
---|
4253 | (uvref *simple-predicate-function-prototype* 0) |
---|
4254 | datum |
---|
4255 | function |
---|
4256 | nil |
---|
4257 | (dpb 1 $lfbits-numreq 0)) |
---|
4258 | #+x86-target |
---|
4259 | (%clone-x86-function |
---|
4260 | *simple-predicate-function-prototype* |
---|
4261 | datum |
---|
4262 | function |
---|
4263 | nil |
---|
4264 | (dpb 1 $lfbits-numreq 0))) |
---|
4265 | |
---|
4266 | (defun check-ctypep (thing ctype) |
---|
4267 | (multiple-value-bind (win sure) (ctypep thing ctype) |
---|
4268 | (or win (not sure)))) |
---|
4269 | |
---|
4270 | |
---|
4271 | (defun generate-predicate-for-ctype (ctype) |
---|
4272 | (typecase ctype |
---|
4273 | (numeric-ctype |
---|
4274 | (or (numeric-ctype-predicate ctype) |
---|
4275 | (make-simple-type-predicate 'numeric-%%typep ctype))) |
---|
4276 | (array-ctype |
---|
4277 | (make-simple-type-predicate 'array-%%typep ctype)) |
---|
4278 | (member-ctype |
---|
4279 | (make-simple-type-predicate 'member-%%typep ctype)) |
---|
4280 | (named-ctype |
---|
4281 | (case (named-ctype-name ctype) |
---|
4282 | ((* t) #'true) |
---|
4283 | (t #'false))) |
---|
4284 | (cons-ctype |
---|
4285 | (make-simple-type-predicate 'cons-%%typep ctype)) |
---|
4286 | (function-ctype |
---|
4287 | #'functionp) |
---|
4288 | (class-ctype |
---|
4289 | (make-simple-type-predicate 'class-cell-typep (find-class-cell (class-name (class-ctype-class ctype)) t))) |
---|
4290 | (t |
---|
4291 | (make-simple-type-predicate 'check-ctypep ctype)))) |
---|
4292 | |
---|
4293 | |
---|
4294 | |
---|
4295 | |
---|
4296 | |
---|
4297 | ;;; Ensure that standard EFFECTIVE-SLOT-DEFINITIONs have a meaningful |
---|
4298 | ;;; type predicate, if we can. |
---|
4299 | (defmethod shared-initialize :after ((spec effective-slot-definition) |
---|
4300 | slot-names |
---|
4301 | &key |
---|
4302 | &allow-other-keys) |
---|
4303 | (declare (ignore slot-names)) |
---|
4304 | (let* ((type (slot-definition-type spec))) |
---|
4305 | (setf (slot-value spec 'type-predicate) |
---|
4306 | (or (and (typep type 'symbol) |
---|
4307 | (not (eq type 't)) |
---|
4308 | (type-predicate type)) |
---|
4309 | (handler-case |
---|
4310 | (let* ((ctype (specifier-type type))) |
---|
4311 | (unless (eq ctype *universal-type*) |
---|
4312 | (generate-predicate-for-ctype ctype))) |
---|
4313 | (parse-unknown-type (c) |
---|
4314 | (declare (ignore c)) |
---|
4315 | #'(lambda (value) |
---|
4316 | ;; If the type's now known, install a new predicate. |
---|
4317 | (let* ((nowctype (specifier-type type))) |
---|
4318 | (unless (typep nowctype 'unknown-ctype) |
---|
4319 | (setf (slot-value spec 'type-predicate) |
---|
4320 | (generate-predicate-for-ctype nowctype))) |
---|
4321 | (multiple-value-bind (win sure) |
---|
4322 | (ctypep value nowctype) |
---|
4323 | (or (not sure) win)))))))))) |
---|
4324 | |
---|