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