1 |
|
;; -*-Lisp-*- |
2 |
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
3 |
|
|
4 |
;; This file is part of GNU Common Lisp, herein referred to as GCL |
;; This file is part of GNU Common Lisp, herein referred to as GCL |
25 |
|
|
26 |
(in-package 'system) |
(in-package 'system) |
27 |
|
|
28 |
(export '(lisp::deftype lisp::typep lisp::subtypep lisp::coerce lisp::upgraded-array-element-type) 'lisp) |
(export '(lisp::upgraded-complex-part-type |
29 |
|
lisp::deftype lisp::typep lisp::subtypep |
30 |
|
lisp::coerce lisp::upgraded-array-element-type) 'lisp) |
31 |
|
|
32 |
(eval-when (compile) |
(eval-when (compile) |
33 |
(proclaim '(optimize (safety 2) (space 3))) |
(proclaim '(optimize (safety 2) (space 3))) |
160 |
(not (array-has-fill-pointer-p x)) |
(not (array-has-fill-pointer-p x)) |
161 |
(not (si:displaced-array-p x)))) |
(not (si:displaced-array-p x)))) |
162 |
|
|
163 |
|
(deftype list () `(or cons nil)) |
164 |
|
(deftype sequence () `(or list vector)) |
165 |
|
(deftype character () `(or base-char extended-char)) |
166 |
|
(deftype string-char () `(or base-char extended-char)) |
167 |
|
(deftype stream () `(or broadcast-stream concatenated-stream echo-stream |
168 |
|
file-stream string-stream synonym-stream two-way-stream)) |
169 |
|
|
170 |
|
(deftype bignum () `(and integer (not fixnum))) |
171 |
|
(deftype rational (&optional (low '*) (high '*)) `(or (integer ,low ,high) (ratio ,low ,high))) |
172 |
|
(deftype float (&optional (low '*) (high '*)) `(or (short-float ,low ,high) (long-float ,low ,high))) |
173 |
|
(deftype single-float (&optional (low '*) (high '*)) `(long-float ,low ,high)) |
174 |
|
(deftype double-float (&optional (low '*) (high '*)) `(long-float ,low ,high)) |
175 |
|
(deftype real (&optional (low '*) (high '*)) `(or (rational ,low ,high) (float ,low ,high))) |
176 |
|
(deftype number () `(or real complex)) |
177 |
|
;(deftype boolean () `(member t nil)) ;FIXME member types |
178 |
|
(deftype atom () `(not cons)) |
179 |
|
(deftype function () `(or interpreted-function compiled-function)) |
180 |
|
(deftype symbol () `(or non-keyword-boolean-symbol null is-t keyword)) |
181 |
|
(deftype base-char () `(or standard-char non-standard-base-char)) |
182 |
|
;(deftype t () `(or atom cons)) |
183 |
|
|
184 |
|
(deftype integer (&optional (low '*) (high '*)) `(integer ,low ,high)) |
185 |
|
(deftype ratio (&optional (low '*) (high '*)) `(ratio ,low ,high)) |
186 |
|
(deftype short-float (&optional (low '*) (high '*)) `(short-float ,low ,high)) |
187 |
|
(deftype long-float (&optional (low '*) (high '*)) `(long-float ,low ,high)) |
188 |
|
|
189 |
|
(deftype array (&optional (et '*) (dims '*)) |
190 |
|
`(array ,et ,(if (integerp dims) (make-list dims :initial-element '*) dims))) |
191 |
|
(deftype simple-array (&optional (et '*) (dims '*)) |
192 |
|
`(simple-array ,et ,(if (integerp dims) (make-list dims :initial-element '*) dims))) |
193 |
|
|
194 |
|
(defun upgraded-complex-part-type (type &optional environment) (declare (ignore environment)) type) |
195 |
|
|
196 |
|
(deftype complex (&optional (ts 'real)) `(complex ,(if (eq ts '*) 'real ts))) |
197 |
|
(deftype eql (x) `(member ,x)) |
198 |
|
|
199 |
|
|
200 |
|
(defconstant +singleton-types+ '(cons non-keyword-boolean-symbol is-t null keyword standard-char |
201 |
|
non-standard-base-char extended-char |
202 |
|
package |
203 |
|
broadcast-stream concatenated-stream echo-stream file-stream string-stream |
204 |
|
synonym-stream two-way-stream |
205 |
|
pathname readtable hash-table random-state structure |
206 |
|
interpreted-function compiled-function)) |
207 |
|
|
208 |
|
(defvar *singleton-types* '#.(reverse (let ((i -1)) (mapcar (lambda (x) `(,x . ,(ash 1 (incf i)))) +singleton-types+)))) |
209 |
|
|
210 |
|
(defmacro mbtp (x) `(and (consp ,x) (eq (car ,x) 'member))) |
211 |
|
|
212 |
|
(defun singleton-tp-from-int (x) |
213 |
|
(let ((z (mapcar 'car (remove-if (lambda (z) (= 0 (logand x z))) *singleton-types* :key 'cdr)))) |
214 |
|
(if (cdr z) |
215 |
|
`(or ,@z) |
216 |
|
z))) |
217 |
|
|
218 |
|
(defun singleton-op (op x &optional y) |
219 |
|
(let ((x (if (integerp x) x (or (cdr (assoc x *singleton-types*)) (if x -1 0)))) |
220 |
|
(y (if (integerp y) y (or (cdr (assoc y *singleton-types*)) (if y -1 0))))) |
221 |
|
(case op |
222 |
|
(and (logand x y)) |
223 |
|
(or (logior x y)) |
224 |
|
(not (lognot x))))) |
225 |
|
|
226 |
|
|
227 |
|
;(defstruct tp |
228 |
|
; (nums (make-list 8) :type list) |
229 |
|
; single |
230 |
|
; array |
231 |
|
; struct |
232 |
|
; class) |
233 |
|
|
234 |
|
(defconstant +range-types+ `(integer ratio short-float long-float)) |
235 |
|
(defconstant +array-types+ '(character bit signed-char unsigned-char signed-short unsigned-short |
236 |
|
fixnum short-float long-float t)) |
237 |
|
|
238 |
|
(defmacro make-tp () `(list (make-list ,#.(* 2 (length +range-types+))) |
239 |
|
nil |
240 |
|
(make-list ,#.(length +array-types+)) |
241 |
|
nil nil)) |
242 |
|
(defmacro tp-nums (tp) `(first ,tp)) |
243 |
|
(defmacro tp-single (tp) `(second ,tp)) |
244 |
|
(defmacro tp-array (tp) `(third ,tp)) |
245 |
|
(defmacro tp-struct (tp) `(fourth ,tp)) |
246 |
|
(defmacro tp-class (tp) `(fifth ,tp)) |
247 |
|
|
248 |
|
(defun class< (x y) |
249 |
|
(cond ((and (consp x) (eq (car x) 'member)) (every (lambda (z) (typep z y)) (cdr x))) |
250 |
|
((and (consp y) (eq (car y) 'member)) nil) |
251 |
|
((let ((x (if (symbolp x) (find-class x nil) x)) |
252 |
|
(y (if (symbolp y) (find-class y nil) y))) |
253 |
|
(or (not x) (and y (member y (class-precedence-list x)))))))) |
254 |
|
|
255 |
|
(defun struct< (x y) |
256 |
|
(cond ((and (consp x) (eq (car x) 'member)) (every (lambda (z) (typep z y)) (cdr x))) |
257 |
|
((and (consp y) (eq (car y) 'member)) nil) |
258 |
|
((or (not x) (eq y t))) |
259 |
|
((let ((x (and (symbolp x) (get x 's-data))) |
260 |
|
(y (and (symbolp y) (get y 's-data)))) |
261 |
|
(and x y (do ((x x (s-data-includes x))) ((or (not x) (eq x y)) (eq x y)))))))) |
262 |
|
|
263 |
|
|
264 |
|
(defun op-from-inclusion (op ox oy < atm) |
265 |
|
(let* ((cx (and (consp ox) (eq (car ox) 'not))) |
266 |
|
(x (if cx (cadr ox) ox)) |
267 |
|
(cy (and (consp oy) (eq (car oy) 'not))) |
268 |
|
(y (if cy (cadr oy) oy)) |
269 |
|
(<xy (funcall < x y)) |
270 |
|
(<yx (funcall < y x)) |
271 |
|
(opor (case op (or t) (and nil) (otherwise (error "Bad op~%"))))) |
272 |
|
(cond ((not (or cx cy)) |
273 |
|
(cond (<xy (if opor y x)) |
274 |
|
(<yx (if opor x y)) |
275 |
|
((when opor (clean-or atm `(or ,x ,y)))))) |
276 |
|
((and cx cy) |
277 |
|
(cond (<xy `(not ,(if opor x y))) |
278 |
|
(<yx `(not ,(if opor y x))) |
279 |
|
((if opor t (clean-and atm `(and (not ,x) (not ,y))))))) |
280 |
|
(cx (op-from-inclusion op oy ox < atm)) |
281 |
|
((cond ((and <xy <yx) opor) |
282 |
|
(<xy (when opor (clean-or atm `(or ,x (not ,y))))) |
283 |
|
(<yx (if opor t (clean-and atm `(and ,x (not ,y))))) |
284 |
|
((if opor `(not ,y) x))))))) |
285 |
|
|
286 |
|
;(defun compound (x) |
287 |
|
; (cond ((atom x) nil) |
288 |
|
; ((eq (car x) 'not) (compound (cadr x))) |
289 |
|
; ((consp (car x))) |
290 |
|
; ((member (car x) '(and or t nil))))) |
291 |
|
; |
292 |
|
;(defmacro atomic-tp (x) `(not (compound ,x))) |
293 |
|
|
294 |
|
(defun classatm (x) |
295 |
|
(cond ((atom x)) |
296 |
|
((eq (car x) 'not) (classatm (cadr x))) |
297 |
|
((eq (car x) 'member)))) |
298 |
|
|
299 |
|
(defun structatm (x) (classatm x)) |
300 |
|
(defun dimatm (x) |
301 |
|
(cond ((atom x)) |
302 |
|
((eq (car x) 'not) (dimatm (cadr x))) |
303 |
|
((integerp (car x))) |
304 |
|
((eq (car x) t)))) |
305 |
|
|
306 |
|
(defun clean-or (atm lst) |
307 |
|
(if (funcall atm lst) lst |
308 |
|
(or |
309 |
|
(car (member t lst)) |
310 |
|
(let ((nl (remove-if 'not (remove-duplicates (cdr lst) :test 'equal)))) |
311 |
|
(if (cdr nl) `(or ,@nl) (car nl)))))) |
312 |
|
|
313 |
|
(defun clean-and (atm lst) |
314 |
|
(if (funcall atm lst) lst |
315 |
|
(unless (member nil lst) |
316 |
|
(let ((nl (remove-if (lambda (z) (eq z t)) (remove-duplicates (cdr lst) :test 'equal)))) |
317 |
|
(if (cdr nl) `(and ,@nl) (or (car nl) t)))))) |
318 |
|
|
319 |
|
(defun repl-op (op x y < atm) |
320 |
|
(let ((z (inclusion-op op x y < atm))) |
321 |
|
(if (funcall atm z) z y))) |
322 |
|
|
323 |
|
(defun clean-tp (op atm x &optional y) |
324 |
|
(let ((cf (case op (or 'clean-or) (and 'clean-and) (otherwise (error "Bad op~%")))) |
325 |
|
(x (if (funcall atm x) (list x) x)) |
326 |
|
(y (if (funcall atm y) (list y) y))) |
327 |
|
(cond ((not (car y)) (funcall cf atm `(,op ,@x))) |
328 |
|
((eq (car y) op) (funcall cf atm `(,op ,@x ,@(cdr y)))) |
329 |
|
((member (car y) '(and not or)) `(,op ,@x ,y)) |
330 |
|
((funcall cf atm `(,op ,@x ,@y)))))) |
331 |
|
|
332 |
|
(defun clean-not (atm lst) |
333 |
|
(cond ((atom lst) lst) |
334 |
|
((and (eq (car lst) 'not) (consp (cadr lst)) (eq (caadr lst) 'not)) |
335 |
|
(clean-not atm (cadadr lst))) |
336 |
|
((eq (cadr lst) t) nil) |
337 |
|
((and (cdr lst) (not (cadr lst)))) |
338 |
|
(lst))) |
339 |
|
|
340 |
|
(defun inclusion-op (op x y < atm) |
341 |
|
(cond ((and (not (funcall atm x)) (eq op (car x))) |
342 |
|
(inclusion-op op (cadr x) (clean-tp op atm (cddr x) y) < atm)) |
343 |
|
((and (not (funcall atm x)) (eq 'not (car x))) |
344 |
|
(clean-not atm `(not ,(inclusion-op (if (eq op 'or) 'and 'or) (clean-not atm `(not ,x)) (clean-not atm `(not ,y)) < atm)))) |
345 |
|
((not (funcall atm x)) |
346 |
|
(clean-tp (if (eq op 'or) 'and 'or) atm (mapcar (lambda (w) (inclusion-op op w y < atm)) (cdr x)))) |
347 |
|
((funcall atm y) (op-from-inclusion op x y < atm)) |
348 |
|
((eq op (car y)) |
349 |
|
(let ((z (clean-tp op atm (if (some (lambda (z) (equal z (inclusion-op op x z < atm))) (cdr y)) |
350 |
|
(eq op 'and) x) |
351 |
|
(mapcar (lambda (z) (repl-op op x z < atm)) (cdr y))))) |
352 |
|
(if (funcall atm z) z |
353 |
|
(let ((ny (clean-tp op atm (cddr z)))) |
354 |
|
(if (and (equal x (cadr z)) (equal ny y)) |
355 |
|
z |
356 |
|
(inclusion-op op (cadr z) ny < atm)))))) |
357 |
|
((eq 'not (car y)) |
358 |
|
(clean-not atm `(not ,(inclusion-op (if (eq op 'or) 'and 'or) (clean-not atm `(not ,x)) (clean-not atm `(not ,y)) < atm)))) |
359 |
|
((clean-tp (if (eq op 'or) 'and 'or) atm (mapcar (lambda (w) (inclusion-op op x w < atm)) (cdr y)))))) |
360 |
|
|
361 |
|
; ((inclusion-op op y x <))))); |
362 |
|
|
363 |
|
(defun andf (&rest args) |
364 |
|
(or (not args) (and (car args) (cadr args)))) |
365 |
|
|
366 |
|
(defun dim< (x y) |
367 |
|
(cond ((or (eq y t) (not x))) |
368 |
|
((or (eq x t) (not y)) nil) |
369 |
|
((integerp x) (if (integerp y) (= x y) (and (consp y) (= x (length y)) (every (lambda (z) (eq z t)) y)))) |
370 |
|
((integerp y) (dim< x (make-list y :initial-element t))) |
371 |
|
((/= (length x) (length y)) nil) |
372 |
|
((every (lambda (z) (eq z t)) (mapcar 'dim< x y))))) |
373 |
|
|
374 |
|
(defun array-op (op x &optional y) ;(declare (ignore op x y)) nil) |
375 |
|
(case op |
376 |
|
(not (mapcar (lambda (z) (clean-not 'dimatm `(not ,z))) x)) |
377 |
|
(otherwise (mapcar (lambda (x y) (inclusion-op op x y 'dim< 'dimatm)) x y)))) |
378 |
|
|
379 |
|
(defun tp-and (&rest xy) |
380 |
|
(when xy |
381 |
|
(let ((x (car xy)) (y (cadr xy))) |
382 |
|
(when x |
383 |
|
(setf (tp-nums x) (mapcar 'range-and (tp-nums x) (tp-nums y))) |
384 |
|
(setf (tp-single x) (singleton-op 'and (tp-single x) (tp-single y))) |
385 |
|
(setf (tp-array x) (array-op 'and (tp-array x) (tp-array y))) |
386 |
|
(setf (tp-struct x) (inclusion-op 'and (tp-struct x) (tp-struct y) 'struct< 'structatm)) |
387 |
|
(setf (tp-class x) (inclusion-op 'and (tp-class x) (tp-class y) 'class< 'classatm))) |
388 |
|
x))) |
389 |
|
|
390 |
|
(defun tp-or (&rest xy) |
391 |
|
(when xy |
392 |
|
(let ((x (car xy)) (y (cadr xy))) |
393 |
|
(when x |
394 |
|
(setf (tp-nums x) (mapcar 'range-or (tp-nums x) (tp-nums y))) |
395 |
|
(setf (tp-single x) (singleton-op 'or (tp-single x) (tp-single y))) |
396 |
|
(setf (tp-array x) (array-op 'or (tp-array x) (tp-array y))) |
397 |
|
(setf (tp-struct x) (inclusion-op 'or (tp-struct x) (tp-struct y) 'struct< 'structatm)) |
398 |
|
(setf (tp-class x) (inclusion-op 'or (tp-class x) (tp-class y) 'class< 'classatm))) |
399 |
|
x))) |
400 |
|
|
401 |
|
(defun tp-not (x) |
402 |
|
(when x |
403 |
|
(setf (tp-nums x) (mapcar 'range-not (tp-nums x))) |
404 |
|
(setf (tp-single x) (singleton-op 'not (tp-single x))) |
405 |
|
(setf (tp-array x) (array-op 'not (tp-array x))) |
406 |
|
(setf (tp-struct x) (clean-not 'structatm `(not ,(tp-struct x))));FIXME |
407 |
|
(setf (tp-class x) (clean-not 'classatm `(not ,(tp-class x))))) |
408 |
|
x) |
409 |
|
|
410 |
|
(defun tp-load (type shift &aux tem) |
411 |
|
(let ((tp (make-tp))) |
412 |
|
(cond ((eq (car type) t) (tp-not tp)) |
413 |
|
((setq tem (position (car type) +range-types+)) |
414 |
|
(setf (nth (+ shift tem) (tp-nums tp)) |
415 |
|
(let ((z `((,(cadr type) . ,(caddr type))))) |
416 |
|
(number-range-fixup z (nth tem +range-types+))))) |
417 |
|
((member (car type) +singleton-types+) |
418 |
|
(setf (tp-single tp) (car type))) |
419 |
|
((member (car type) '(array simple-array)) |
420 |
|
(let ((z (position (if (eq (cadr type) 'string-char) 'character (cadr type)) +array-types+)));FIXME |
421 |
|
(unless (or z (eq (cadr type) '*)) (error "Bad array type ~a~%" (cadr type))) |
422 |
|
(let* ((dim (caddr type)) |
423 |
|
(dim (if (eq dim '*) t dim)) |
424 |
|
(dim (if (listp dim) (mapcar (lambda (z) (or (eq '* z) z)) dim) dim))) |
425 |
|
(if z |
426 |
|
(setf (nth z (tp-array tp)) dim) |
427 |
|
(setf (tp-array tp) (mapcar (lambda (z) (declare (ignore z)) dim) (tp-array tp))))))) |
428 |
|
((setq tem (or (and (symbolp (car type)) (find-class (car type) nil)) (when (classp (car type)) (car type)))) |
429 |
|
(setf (tp-class tp) tem)) |
430 |
|
((and (symbolp (car type)) (setq tem (get (car type) 'si::s-data))) |
431 |
|
; (setf (tp-struct tp) tem))FIXME |
432 |
|
(setf (tp-struct tp) (car type))) |
433 |
|
((eq (car type) 'member) |
434 |
|
(dolist (l (cdr type)) |
435 |
|
(cond ((setq tem (position-if (lambda (x) (typep l x)) +range-types+)) |
436 |
|
(setf (nth tem (tp-nums tp)) |
437 |
|
(range-or (let ((z `((,l . ,l)))) |
438 |
|
(number-range-fixup z (nth tem +range-types+))) |
439 |
|
(nth tem (tp-nums tp))))) |
440 |
|
((setq tem (position-if (lambda (x) (typep l x)) +singleton-types+)) |
441 |
|
(setf (tp-single tp) (if (consp (tp-single tp)) `(,@(tp-single tp) ,l) `(member ,l)))) |
442 |
|
((setq tem (position-if (lambda (x) (typep l `(complex ,x))) +range-types+)) ;;FIXME |
443 |
|
(setf (nth (+ (length +range-types+) tem) (tp-nums tp)) |
444 |
|
(range-or (let ((z `((,(realpart l) . ,(realpart l))))) |
445 |
|
(number-range-fixup z (nth tem +range-types+))) |
446 |
|
(range-or (let ((z `((,(imagpart l) . ,(imagpart l))))) |
447 |
|
(number-range-fixup z (nth tem +range-types+))) |
448 |
|
(nth (+ (length +range-types+) tem) (tp-nums tp))))))))) |
449 |
|
((car type) (setq tp (tp-not tp)))) ;(format t "not processing type ~a~%" type) |
450 |
|
tp)) |
451 |
|
|
452 |
|
(defun reconstruct-type (tp) |
453 |
|
(if (and (consp tp) (eq (car tp) 'cons) (cdr tp)) |
454 |
|
(let ((a (reconstruct-type (cadr tp))) |
455 |
|
(d (reconstruct-type (caddr tp)))) |
456 |
|
(and a d `(cons ,(reconstruct-type (cadr tp)) ,(reconstruct-type (caddr tp))))) |
457 |
|
(let* ((res (when (some 'identity (tp-nums tp)) |
458 |
|
(remove-if |
459 |
|
'not |
460 |
|
(append |
461 |
|
(mapcan (lambda (x y) |
462 |
|
(mapcar (lambda (y) |
463 |
|
(let ((y (car (number-range-fixup (list y) x)))) |
464 |
|
(when y `(,x ,(car y) ,(cdr y))))) y)) |
465 |
|
+range-types+ (tp-nums tp)) |
466 |
|
(mapcan (lambda (x y) |
467 |
|
(mapcar (lambda (y) |
468 |
|
(let ((y (car (number-range-fixup (list y) x)))) |
469 |
|
(when y `(complex (,x ,(car y) ,(cdr y)))))) y)) |
470 |
|
+range-types+ (nthcdr 4 (tp-nums tp))))))) |
471 |
|
(res (if (some 'identity (tp-array tp)) |
472 |
|
`(,@res ,@(remove-if |
473 |
|
'not |
474 |
|
(mapcan (lambda (x y) (mapcar (lambda (y) (when y `(array ,x ,y))) (if (atom y) (list y) y))) |
475 |
|
+array-types+ (tp-array tp)))) res)) |
476 |
|
(res (if (tp-single tp) |
477 |
|
`(,@res ,@(remove-if |
478 |
|
'not |
479 |
|
(mapcar (lambda (z) |
480 |
|
(when (/= 0 (logand (cdr z) (tp-single tp))) |
481 |
|
(car z))) *singleton-types*))) res)) |
482 |
|
(res (if (tp-struct tp) `(,@res ,(tp-struct tp)) res)) |
483 |
|
(res (if (tp-class tp) `(,@res ,(tp-class tp)) res))) |
484 |
|
(when res |
485 |
|
(if (cdr res) |
486 |
|
(clean-tp 'or 'null res) |
487 |
|
(car res)))))) |
488 |
|
|
489 |
|
|
490 |
|
(defun resolve-type (type) |
491 |
|
; (format t "norm~%") |
492 |
|
; (setq type (time (normalize-type type t))) |
493 |
|
; (format t "proc~%") |
494 |
|
; (setq type (time (process-type type))) |
495 |
|
; (format t "recon~%") |
496 |
|
; (setq type (time (reconstruct-type type)))) |
497 |
|
; (let* ((type (time (normalize-type type t))) |
498 |
|
; (type (time (process-type type))) |
499 |
|
; (type (time (reconstruct-type type)))) |
500 |
|
; type)) |
501 |
|
(reconstruct-type (process-type (normalize-type type t)))) |
502 |
|
|
503 |
|
|
504 |
|
(defun tp-and1 (&rest xy) |
505 |
|
(when xy |
506 |
|
`(and ,@xy))) |
507 |
|
|
508 |
|
(defun tp-or1 (&rest xy) |
509 |
|
(when xy |
510 |
|
`(or ,@xy))) |
511 |
|
|
512 |
|
(defun tp-not1 (&rest xy) |
513 |
|
(when xy |
514 |
|
`(not ,@xy))) |
515 |
|
|
516 |
|
|
517 |
|
|
518 |
|
(defun process-type (type &optional (shift 0)) |
519 |
|
(cond ((not type) type) |
520 |
|
; ((and (setq tem (normalize-type type)) (not (equal type tem)) (not (eq (car tem) 'satisfies))) |
521 |
|
; (process-type tem shift)) |
522 |
|
((eq (car type) 'and) (reduce 'tp-and (mapcar (lambda (x) (process-type x shift)) (cdr type)))) |
523 |
|
((eq (car type) 'or) (reduce 'tp-or (mapcar (lambda (x) (process-type x shift)) (cdr type)))) |
524 |
|
((eq (car type) 'not) (tp-not (process-type (cadr type) shift))) |
525 |
|
((eq (car type) 'complex) (process-type (cadr type) 4)) |
526 |
|
; ((and (eq (car type) 'cons) (cdr type)) `(cons ,(process-type (cadr type)) ,(process-type (caddr type)))) |
527 |
|
((tp-load type shift)))) |
528 |
|
|
529 |
|
(deftype boolean () `(or null is-t)) |
530 |
|
(defun is-t-p (x) (eq x t));FIXME member types |
531 |
|
|
532 |
|
(defun non-keyword-boolean-symbol-p (x) |
533 |
|
(and (symbolp x) (not (keywordp x)) (not (null x)) (not (is-t-p x)))) |
534 |
|
|
535 |
|
(defun base-char-p (x) |
536 |
|
(characterp x)) |
537 |
|
|
538 |
|
(defun non-standard-base-char-p (x) |
539 |
|
(and (base-char-p x) (not (standard-char-p x)))) |
540 |
|
|
541 |
|
(defun extended-char-p (x) (declare (ignore x)) nil) |
542 |
|
|
543 |
|
(defun interpreted-function-p (x) |
544 |
|
(and (functionp x) (not (compiled-function-p x)))) |
545 |
|
|
546 |
|
|
547 |
(do ((l '((null . null) |
(do ((l '((null . null) |
548 |
(symbol . symbolp) |
(symbol . symbolp) |
549 |
(keyword . keywordp) |
(keyword . keywordp) |
550 |
|
(is-t . is-t-p) |
551 |
|
(non-keyword-boolean-symbol . non-keyword-boolean-symbol-p) |
552 |
|
(standard-char . standard-char-p) |
553 |
|
(base-char . base-char-p) |
554 |
|
(extended-char . extended-char-p) |
555 |
|
(string-char . string-char-p);;FIXME |
556 |
|
(interpreted-function . interpreted-function-p) |
557 |
(atom . atom) |
(atom . atom) |
558 |
(cons . consp) |
(cons . consp) |
559 |
(list . listp) |
(list . listp) |
576 |
(cdr l))) |
(cdr l))) |
577 |
((endp l)) |
((endp l)) |
578 |
(si:putprop (caar l) (cdar l) 'type-predicate) |
(si:putprop (caar l) (cdar l) 'type-predicate) |
579 |
(si:putprop (cdar l) (caar l) 'predicate-type)) |
(when (symbolp (cdar l)) (si:putprop (cdar l) (caar l) 'predicate-type))) |
580 |
|
|
581 |
|
|
582 |
|
(defun classp (object) (declare (ignore object)) nil) |
583 |
|
(defun class-precedence-list (object) (declare (ignore object)) nil) |
584 |
|
(defun find-class (object &optional errorp environment) (declare (ignore object errorp environment))nil) |
585 |
|
|
586 |
|
(defmacro range-num (x) `(if (atom ,x) ,x (car ,x))) |
587 |
|
|
588 |
|
(defun elgt (x y) |
589 |
|
(cond ((or (eq (car x) '*) (eq (cdr y) '*)) nil) |
590 |
|
((and (numberp (car x)) (numberp (cdr y))) (> (car x) (cdr y))) |
591 |
|
((>= (range-num (car x)) (range-num (cdr y)))))) |
592 |
|
|
593 |
|
(defun elin (x y op) |
594 |
|
(cond ((eq x '*) y) |
595 |
|
((eq y '*) x) |
596 |
|
((= (range-num x) (range-num y)) (if (atom x) y x)) |
597 |
|
((funcall op (range-num x) (range-num y)) x) |
598 |
|
(y))) |
599 |
|
|
600 |
|
(defun elout (x y op) |
601 |
|
(cond ((eq x '*) x) |
602 |
|
((eq y '*) y) |
603 |
|
((= (range-num x) (range-num y)) (if (atom x) x y)) |
604 |
|
((funcall op (range-num x) (range-num y)) x) |
605 |
|
(y))) |
606 |
|
|
607 |
|
(defun range-and (x y &optional res) |
608 |
|
(cond ((or (not x) (not y)) (nreverse res));(if (and (not x) (not y)) res (cons (car (or x y)) res)))) |
609 |
|
((elgt (car y) (car x)) (range-and (cdr x) y res)) |
610 |
|
((elgt (car x) (car y)) (range-and x (cdr y) res)) |
611 |
|
((let ((z (elin (cdar y) (cdar x) '<))) |
612 |
|
(range-and (if (equal z (cdar x)) (cdr x) x) (if (equal z (cdar y)) (cdr y) y) |
613 |
|
(cons (cons (elin (caar x) (caar y) '>) z) res)))))) |
614 |
|
|
615 |
|
(defun range-or (x y &optional res) |
616 |
|
(cond ((and (not x) (not y)) (nreverse res)) |
617 |
|
((not x) (range-or x (cdr y) (cons (car y) res))) |
618 |
|
((not y) (range-or (cdr x) y (cons (car x) res))) |
619 |
|
((elgt (car y) (car x)) (range-or (cdr x) y (cons (car x) res))) |
620 |
|
((elgt (car x) (car y)) (range-or x (cdr y) (cons (car y) res))) |
621 |
|
((and (equal (elout (caar x) (caar y) '<) (caar x)) |
622 |
|
(equal (elout (cdar y) (cdar x) '>) (cdar x))) (range-or x (cdr y) res)) |
623 |
|
((and (equal (elout (caar x) (caar y) '<) (caar y)) |
624 |
|
(equal (elout (cdar y) (cdar x) '>) (cdar y))) (range-or (cdr x) y res)) |
625 |
|
((range-or (cdr x) (cdr y);(if (equal (caar x) z) (cdr x) x) (if (equal (caar y) z) (cdr y) y) |
626 |
|
(cons (cons (elout (caar x) (caar y) '<) (elout (cdar y) (cdar x) '>)) res))))) |
627 |
|
|
628 |
|
(defmacro elcomp (x) `(cond ((eq ,x '*) ,x) ((atom ,x) (list ,x)) ((car ,x)))) |
629 |
|
|
630 |
|
(defun range-not (x &optional res (last '* lastp)) |
631 |
|
(cond ((not x) (nreverse (if (and lastp (eq last '*)) res (cons (cons (elcomp last) '*) res)))) |
632 |
|
((range-not (cdr x) (if (eq (caar x) last) res (cons (cons (elcomp last) (elcomp (caar x))) res)) (cdar x))))) |
633 |
|
; (let* ((el (elcomp last)) |
634 |
|
; (ex (elcomp (caar x))) |
635 |
|
; (il (if (atom el) el (car el))) |
636 |
|
; (ix (if (atom ex) ex (car ex)))) |
637 |
|
; (if (and (not (eq il '*)) (not (eq ix '*)) (= il ix) (or (listp el) (listp ex))) |
638 |
|
; res |
639 |
|
; (cons (cons el ex) res))) (cdar x))))) |
640 |
|
|
641 |
|
(defun imod (x p) |
642 |
|
(if (eq x '*) x |
643 |
|
(let* ((e (atom x)) |
644 |
|
(x (if e x (car x))) |
645 |
|
(cx (if (= p 1) (ceiling x) (floor x)))) |
646 |
|
(cond ((/= cx x) cx) |
647 |
|
(e cx) |
648 |
|
((+ cx p)))))) |
649 |
|
|
650 |
|
(defun integer-range-fixup (x &optional res) |
651 |
|
(cond ((not x) (remove-if (lambda (x) (and (realp (car x)) (realp (cdr x)) (> (car x) (cdr x)))) (nreverse res))) |
652 |
|
((integer-range-fixup (cdr x) |
653 |
|
(cons (cons (imod (caar x) 1) (imod (cdar x) -1)) res))))) |
654 |
|
|
655 |
|
(defun number-range-fixup (x tp) |
656 |
|
(if (eq tp 'integer) |
657 |
|
(integer-range-fixup x) |
658 |
|
(remove-if (lambda (x) (let ((a (car x)) (d (cdr x))) |
659 |
|
(let ((na (if (atom a) a (car a))) (nd (if (atom d) d (car d)))) |
660 |
|
(and (not (eq na '*)) (not (eq nd '*)) |
661 |
|
(= na nd) |
662 |
|
(or (listp a) (listp d)))))) x))) |
663 |
|
|
664 |
|
(defconstant +real-type-alist+ '((integer) |
665 |
|
(ratio) |
666 |
|
(short-float) |
667 |
|
(long-float) |
668 |
|
(rational integer ratio) |
669 |
|
(single-float long-float) |
670 |
|
(double-float long-float) |
671 |
|
(float long-float short-float) |
672 |
|
(real rational float))) |
673 |
|
|
674 |
|
(defconstant +numeric-logic-alist+ '((and . range-and) (or . range-or))) |
675 |
|
|
676 |
|
;;coerce nums t prope type |
677 |
|
;; sort non-reals |
678 |
|
;; comples |
679 |
|
(defun do-real-ranges (type &aux tem) |
680 |
|
(cond ((assoc type +real-type-alist+) (do-real-ranges `(,type * *))) |
681 |
|
((atom type) nil) |
682 |
|
((setq tem (cdr (assoc (car type) +numeric-logic-alist+) )) |
683 |
|
(reduce (lambda (x y) (mapcar tem x y)) (mapcar 'do-real-ranges (cdr type)))) |
684 |
|
((eq (car type) 'not) |
685 |
|
(mapcar 'range-not (do-real-ranges (cadr type)))) |
686 |
|
((eq (car type) 'member) |
687 |
|
(do-real-ranges |
688 |
|
`(or ,@(mapcar (lambda (x) |
689 |
|
(let ((tt (car (assoc x +real-type-alist+ :test 'typep)))) |
690 |
|
(when tt `(,tt ,x ,x)))) (cdr type))))) |
691 |
|
((setq tem (cdr (assoc (car type) +real-type-alist+))) |
692 |
|
(do-real-ranges `(or ,@(mapcar (lambda (x) `(,x ,@(cdr type))) tem)))) |
693 |
|
((setq tem (position (car type) +real-type-alist+ :key 'car)) |
694 |
|
(append (make-list tem) (list (list (cons (or (cadr type) '*) (or (caddr type) '*)))) (make-list (- 3 tem)))))) |
695 |
|
|
696 |
|
(defun exnr (type) |
697 |
|
`(or ,@(mapcar (lambda (x y) (when y `(,(car x) ,@y))) +real-type-alist+ (do-real-ranges type)))) |
698 |
|
|
699 |
|
(defun type-null (type) |
700 |
|
(equal type `(or nil nil nil nil))) |
701 |
|
|
702 |
|
(defun subtypep (t1 t2 &optional env) |
703 |
|
(declare (ignore env)) |
704 |
|
(let ((r (not (resolve-type `(and ,t1 (not ,t2)))))) |
705 |
|
(values r t))) |
706 |
|
|
707 |
|
(defun *typep (object type) |
708 |
|
(or (pcl-complete-redirect '*typep object type) |
709 |
|
(pcl-redirect '*typep object type))) |
710 |
|
(defun *subtypep (type1 type2) |
711 |
|
(let ((l (multiple-value-list (pcl-complete-redirect '*subtypep type1 type2)))) |
712 |
|
(if (cdr l) |
713 |
|
(values (car l) (cdr l))) |
714 |
|
(pcl-redirect '*subtypep type1 type2))) |
715 |
|
|
|
(defun class-of (object) |
|
|
(declare (ignore object)) |
|
|
nil) |
|
|
(defun classp (object) |
|
|
(declare (ignore object)) |
|
|
nil) |
|
|
(defun class-precedence-list (object) |
|
|
(declare (ignore object)) |
|
|
nil) |
|
|
(defun find-class (object &optional errorp environment) |
|
|
(declare (ignore object errorp environment)) |
|
|
nil) |
|
|
;(defun find-class-no-error (object) |
|
|
; (declare (ignore object)) |
|
|
; nil) |
|
716 |
|
|
717 |
;;; TYPEP predicate. |
;;; TYPEP predicate. |
718 |
;;; FIXME --optimize with most likely cases first |
;;; FIXME --optimize with most likely cases first |
719 |
(defun typep (object type &optional env &aux tp i tem) |
(defun typep (object type &optional env &aux tp i tem) |
720 |
(declare (ignore env)) |
(declare (ignore env)) |
|
(when (classp type) |
|
|
(return-from typep (if (member type (class-precedence-list (funcall 'class-of object))) t nil))) |
|
721 |
(if (atom type) |
(if (atom type) |
722 |
(setq tp type i nil) |
(setq tp type i nil) |
723 |
(setq tp (car type) i (cdr type))) |
(setq tp (car type) i (cdr type))) |
725 |
(let ((f (and (not i) (get tp 'type-predicate)))) |
(let ((f (and (not i) (get tp 'type-predicate)))) |
726 |
(when f (return-from typep (funcall f object)))) |
(when f (return-from typep (funcall f object)))) |
727 |
(case tp |
(case tp |
728 |
|
(cons (and (consp object) (typep (car object) (car i)) (typep (cdr object) (cadr i)))) |
729 |
(member (member object i)) |
(member (member object i)) |
730 |
(not (not (typep object (car i)))) |
(not (not (typep object (car i)))) |
731 |
(or |
(or |
738 |
(unless (typep object (car l)) (return nil)))) |
(unless (typep object (car l)) (return nil)))) |
739 |
(satisfies (funcall (car i) object)) |
(satisfies (funcall (car i) object)) |
740 |
((t) t) |
((t) t) |
741 |
((nil) nil) |
((nil) (not object)) |
742 |
(boolean (or (eq object 't) (eq object 'nil))) |
(boolean (or (eq object 't) (eq object 'nil))) |
743 |
(fixnum (eq (type-of object) 'fixnum)) |
(fixnum (eq (type-of object) 'fixnum)) |
744 |
(bignum (eq (type-of object) 'bignum)) |
(bignum (eq (type-of object) 'bignum)) |
761 |
(and (eq (type-of object) 'long-float) (in-interval-p object i))) |
(and (eq (type-of object) 'long-float) (in-interval-p object i))) |
762 |
(complex |
(complex |
763 |
(and (complexp object) |
(and (complexp object) |
764 |
|
|
765 |
(or (null i) |
(or (null i) |
766 |
(and (typep (realpart object) (car i)) |
(and (typep (realpart object) (car i)) |
767 |
;;wfs--should only have to check one. |
;;wfs--should only have to check one. |
830 |
)))) |
)))) |
831 |
|
|
832 |
|
|
833 |
|
(defun normalize-type (type &optional ar &aux tem) |
834 |
|
(cond ((atom type) (normalize-type (list type) ar)) |
835 |
|
((and (eq (car type) 'satisfies) (setq tem (get (cadr type) 'predicate-type))) |
836 |
|
(normalize-type tem ar)) |
837 |
|
((let* ((dt (and (symbolp (car type)) (get (car type) 'deftype-definition))) |
838 |
|
(nt (and dt (apply dt (cdr type))))) |
839 |
|
(when (and nt (not (equal type nt)) (not (and (eq (car nt) 'satisfies) (find-class (car type) nil)))) |
840 |
|
(normalize-type nt ar)))) |
841 |
|
((and ar (member (car type) '(array simple-array))) |
842 |
|
`(,(car type) ,(upgraded-array-element-type (cadr type)) ,(caddr type))) |
843 |
|
((eq (car type) 'complex) |
844 |
|
`(complex ,(normalize-type (cadr type) ar))) |
845 |
|
((and (eq (car type) 'cons) (cdr type)) |
846 |
|
(let* ((a (normalize-type (cadr type) ar)) |
847 |
|
(ai (if (cdr a) a (car a))) |
848 |
|
(d (normalize-type (caddr type) ar)) |
849 |
|
(di (if (cdr d) d (car d)))) |
850 |
|
(and ai di `(cons ,a ,d)))) |
851 |
|
((member (car type) '(and or not)) |
852 |
|
(let ((z `(,(car type)))) |
853 |
|
(dolist (l (mapcar (lambda (z) (normalize-type z ar)) (cdr type))) |
854 |
|
(if (and (eq (car l) (car type)) (not (eq (car type) 'not))) |
855 |
|
(dolist (w (cdr l)) (push w z)) |
856 |
|
(push l z))) |
857 |
|
(if (cdr z) |
858 |
|
(nreverse z) |
859 |
|
(case (car z) (and '(t)) (or '(nil)) (not (error "Bad type~%")))))) |
860 |
|
(type))) |
861 |
|
|
862 |
;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions. |
;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions. |
863 |
;;; The result is always a list. |
;;; The result is always a list. |
864 |
(defun normalize-type (type &aux tp i ) |
;(defun normalize-type (type &aux tp i ) |
865 |
;; Loops until the car of type has no DEFTYPE definition. |
;; Loops until the car of type has no DEFTYPE definition. |
866 |
(when (and (consp type) (eq (car type) 'satisfies)) |
; (when (and (consp type) (eq (car type) 'satisfies)) |
867 |
(when (setq tp (get (cadr type) 'predicate-type)) |
; (when (setq tp (get (cadr type) 'predicate-type)) |
868 |
(setq type tp))) |
; (setq type tp))) |
869 |
(loop |
; (loop |
870 |
(if (atom type) |
; (if (atom type) |
871 |
(setq tp type i nil) |
; (setq tp type i nil) |
872 |
(setq tp (car type) i (cdr type))) |
; (setq tp (car type) i (cdr type))) |
873 |
(if (get tp 'deftype-definition) |
; (let* ((dt (get tp 'deftype-definition)) |
874 |
(setq type (apply (get tp 'deftype-definition) i)) |
; (nt (and dt (apply dt i)))) |
875 |
(return-from normalize-type (if (atom type) (list type) type))))) |
; (if (and nt (not (equal type nt))) |
876 |
|
; (setq type nt) |
877 |
|
; (return-from normalize-type (if (atom type) (list type) type)))))) |
878 |
|
|
879 |
|
|
880 |
;;; KNOWN-TYPE-P answers if the given type is a known base type. |
;;; KNOWN-TYPE-P answers if the given type is a known base type. |
884 |
(defun known-type-p (type) |
(defun known-type-p (type) |
885 |
(when (consp type) (setq type (car type))) |
(when (consp type) (setq type (car type))) |
886 |
(if (and (symbolp type) |
(if (and (symbolp type) |
887 |
(or (equal (string type) "ERROR")) ;FIXME error symbol |
(or (equal (string type) "ERROR") ;FIXME error symbol |
888 |
(member type |
(member type |
889 |
'(t nil boolean null symbol keyword atom cons list sequence |
'(t nil boolean null symbol keyword atom cons list sequence |
890 |
non-negative-char negative-char signed-char unsigned-char |
non-negative-char negative-char signed-char unsigned-char |
891 |
non-negative-short negative-short signed-short unsigned-short |
non-negative-short negative-short signed-short unsigned-short |
892 |
non-negative-fixnum negative-fixnum |
non-negative-fixnum negative-fixnum |
893 |
number integer bignum rational ratio float method-combination |
number integer bignum rational ratio float method-combination |
894 |
short-float single-float double-float long-float complex |
short-float single-float double-float long-float complex |
895 |
character standard-char string-char real |
character standard-char string-char real |
896 |
package stream pathname readtable hash-table random-state |
package stream pathname readtable hash-table random-state |
897 |
structure array simple-array function compiled-function |
structure array simple-array function compiled-function |
898 |
arithmetic-error base-char base-string broadcast-stream |
arithmetic-error base-char base-string broadcast-stream |
899 |
built-in-class cell-error class concatenated-stream condition |
built-in-class cell-error class concatenated-stream condition |
900 |
control-error division-by-zero echo-stream end-of-file error |
control-error division-by-zero echo-stream end-of-file error |
901 |
extended-char file-error file-stream floating-point-inexact |
extended-char file-error file-stream floating-point-inexact |
902 |
floating-point-invalid-operation floating-point-overflow |
floating-point-invalid-operation floating-point-overflow |
903 |
floating-point-underflow generic-function logical-pathname method |
floating-point-underflow generic-function logical-pathname method |
904 |
package-error parse-error print-not-readable program-error |
package-error parse-error print-not-readable program-error |
905 |
reader-error serious-condition simple-base-string simple-condition |
reader-error serious-condition simple-base-string simple-condition |
906 |
simple-type-error simple-warning standard-class |
simple-type-error simple-warning standard-class |
907 |
standard-generic-function standard-method standard-object |
standard-generic-function standard-method standard-object |
908 |
storage-condition stream-error string-stream structure-class |
storage-condition stream-error string-stream structure-class |
909 |
style-warning synonym-stream two-way-stream structure-object |
style-warning synonym-stream two-way-stream structure-object |
910 |
type-error unbound-slot unbound-variable undefined-function |
type-error unbound-slot unbound-variable undefined-function |
911 |
warning )) |
warning )) |
912 |
(get type 's-data)) |
(get type 's-data) |
913 |
|
(find-class (implicit-symbol type nil) nil))) |
914 |
t |
t |
915 |
nil)) |
nil)) |
916 |
|
|
923 |
((let ((a (car a))) (or (eq a '*) (eq a t))) |
((let ((a (car a))) (or (eq a '*) (eq a t))) |
924 |
(implicit-symbol (cdr a) b)))) |
(implicit-symbol (cdr a) b)))) |
925 |
|
|
926 |
|
;(defun implicit-symbol (a b) |
927 |
|
; (cond ((atom a) (when (symbolp a) a)) |
928 |
|
; ((subsetp (cdr a) '(t *)) (car a)))) |
929 |
|
|
930 |
(defun upgraded-array-element-type (type &optional environment) |
(defun upgraded-array-element-type (type &optional environment) |
931 |
(declare (ignore environment)) |
(declare (ignore environment)) |
932 |
(best-array-element-type type)) |
(best-array-element-type type)) |
933 |
|
|
934 |
|
(defun type-null (type) |
935 |
|
(cond ((atom type) (not type)) |
936 |
|
((eq (car type) 'and) |
937 |
|
(every (lambda (x) |
938 |
|
(or (and (consp x) (member (car x) '(and or member not))) |
939 |
|
(every (lambda (y) |
940 |
|
(or (and (consp y) (member (car y) '(and or member not))) |
941 |
|
(subtypep x `(not ,y))))))))))) |
942 |
|
|
943 |
|
|
944 |
;;; SUBTYPEP predicate. |
;;; SUBTYPEP predicate. |
945 |
(defun subtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem) |
(defun osubtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem) |
946 |
(declare (ignore env)) |
(declare (ignore env)) |
947 |
(let* ((c1 (classp type1)) (c2 (classp type2)) |
(let* ((t1 (or (find-class (implicit-symbol type1 nil) nil) (when (classp type1) type1))) |
948 |
(t1 (if c1 type1 (let ((nt (implicit-symbol type1 nil))) (and nt (find-class nt nil))))) |
(t2 (or (find-class (implicit-symbol type2 nil) nil) (when (classp type2) type2)))) |
|
(t2 (if c2 type2 (let ((nt (implicit-symbol type2 nil))) (and nt (find-class nt nil)))))) |
|
949 |
(when (and t1 t2) |
(when (and t1 t2) |
950 |
(return-from subtypep |
(return-from osubtypep |
951 |
(if (member t2 (class-precedence-list t1)) |
(if (member t2 (class-precedence-list t1)) |
952 |
(values t t) (values nil t)))) |
(values t t) (values nil t))))) |
953 |
(when (or c1 c2) |
; (when (or t1 t2) |
954 |
(return-from subtypep (values nil t)))) |
; (return-from osubtypep (values nil nil)))) |
955 |
(setq t1 (normalize-type type1)) |
(setq t1 (normalize-type type1)) |
956 |
(setq type1 (if (eq (car t1) 'satisfies) (list type1) t1)) |
(setq type1 (if (eq (car t1) 'satisfies) (list type1) t1)) |
957 |
(setq t2 (normalize-type type2)) |
(setq t2 (normalize-type type2)) |
962 |
(setq i1 (effective-range t1 (cdr type1)) i2 (effective-range t2 (cdr type2))) |
(setq i1 (effective-range t1 (cdr type1)) i2 (effective-range t2 (cdr type2))) |
963 |
(cond ((eq t1 'member) |
(cond ((eq t1 'member) |
964 |
(dolist (e i1) |
(dolist (e i1) |
965 |
(unless (typep e type2) (return-from subtypep (values nil t)))) |
(unless (typep e type2) (return-from osubtypep (values nil t)))) |
966 |
(return-from subtypep (values t t))) |
(return-from osubtypep (values t t))) |
967 |
((eq t1 'or) |
((eq t1 'or) |
968 |
(dolist (tt i1) |
(dolist (tt i1) |
969 |
(multiple-value-bind (tv flag) (subtypep tt (if i2 type2 t2)) |
(multiple-value-bind (tv flag) (osubtypep tt (if i2 type2 t2)) |
970 |
(unless tv (return-from subtypep (values tv flag))))) |
(unless tv (return-from osubtypep (values tv flag))))) |
971 |
(return-from subtypep (values t t))) |
(return-from osubtypep (values t t))) |
972 |
((eq t1 'and) |
((eq t1 'and) |
973 |
(dolist (tt i1) |
(let* ((i1 (remove-duplicates i1 :test 'equal)) |
974 |
(let ((tv (subtypep tt (if i2 type2 t2)))) |
(i1 (if (not (cdr i1)) i1 |
975 |
(when tv (return-from subtypep (values t t))))) |
(intersection i1 i1 :test |
976 |
(return-from subtypep (values nil nil))) |
(lambda (x y) (and (not (equal x y)) |
977 |
|
(let ((r (multiple-value-list (osubtypep x y))) |
978 |
|
(s (multiple-value-list (osubtypep y x)))) |
979 |
|
(or (car r) (not (cadr r)) |
980 |
|
(car s) (not (cadr s)))))))))) |
981 |
|
(unless i1 (return-from osubtypep (values (if (if i2 type2 t2) nil t) t))) |
982 |
|
(dolist (tt i1) |
983 |
|
(let ((tv (osubtypep tt (if i2 type2 t2)))) |
984 |
|
(when tv (return-from osubtypep (values t t))))));;FIXME t2 nil |
985 |
|
(return-from osubtypep (values nil (and (not t2) (some 'known-type-p i1))))) |
986 |
((eq t1 'not) |
((eq t1 'not) |
987 |
;; |
;; |
988 |
(return-from subtypep |
(return-from osubtypep |
989 |
(if (eq t2 'not) |
(if (eq t2 'not) |
990 |
(subtypep (car i2) (car i1)) |
(osubtypep (car i2) (car i1)) |
991 |
(subtypep t `(or ,type2 ,(car i1))))))) |
(let ((r (osubtypep t `(or ,(if i2 type2 t2) ,(car i1))))) |
992 |
|
(values r (or r (osubtypep type1 `(not ,(if i2 type2 t2)))))))))) |
993 |
(cond ((eq t2 'member) |
(cond ((eq t2 'member) |
994 |
(return-from subtypep (values nil nil))) |
(return-from osubtypep (values nil nil))) |
995 |
((eq t2 'or) |
((eq t2 'or) |
996 |
(dolist (tt i2) |
(dolist (tt i2) |
997 |
(let ((tv (subtypep (if i1 type1 t1) tt))) |
(let ((tv (osubtypep (if i1 type1 t1) tt))) |
998 |
(when tv (return-from subtypep (values t t))))) |
(when tv (return-from osubtypep (values t t))))) |
999 |
(return-from subtypep (values nil nil))) |
(return-from osubtypep (values nil (if (eq t1 t) t nil)))) |
1000 |
((eq t2 'and) |
((eq t2 'and) |
1001 |
(dolist (tt i2) |
(dolist (tt i2) |
1002 |
(multiple-value-bind (tv flag) (subtypep (if i1 type1 t1) tt) |
(multiple-value-bind (tv flag) (osubtypep (if i1 type1 t1) tt) |
1003 |
(unless tv (return-from subtypep (values tv flag))))) |
(unless tv (return-from osubtypep (values tv flag))))) |
1004 |
(return-from subtypep (values t t))) |
(return-from osubtypep (values t t))) |
1005 |
((eq t2 'not) |
((eq t2 'not) |
1006 |
(return-from subtypep (subtypep `(and ,type1 ,(car i2)) nil)))) |
(return-from osubtypep (let ((r (osubtypep `(and ,(if i1 type1 t1) ,(car i2)) nil))) |
1007 |
|
(values r (or r (osubtypep (if i1 type1 t1) (car i2)))))))) |
1008 |
|
|
1009 |
(when (equal type1 type2) |
(when (equal type1 type2) |
1010 |
(return-from subtypep (values t t))) |
(return-from osubtypep (values t t))) |
1011 |
(setq ntp1 (known-type-p type1) ntp2 (known-type-p type2)) |
(setq ntp1 (known-type-p type1) ntp2 (known-type-p type2)) |
1012 |
(cond ((or (eq t1 'nil) (eq t2 't) (eq t2 'common) |
(cond ((or (eq t1 'nil) (eq t2 't) (eq t2 'common)) (values t t)) |
|
(and (eq t1 'cons) (or (and i1 (not (car i1))) (and (cdr i1) (not (cadr i1)))))) |
|
|
(values t t)) |
|
1013 |
((eq t2 'nil) (values (eq t1 'extended-char) ntp1)) |
((eq t2 'nil) (values (eq t1 'extended-char) ntp1)) |
1014 |
((eq t1 't) (values nil ntp2)) |
((eq t1 't) (values nil ntp2)) |
1015 |
((eq t1 'common) (values nil ntp2)) |
((eq t1 'common) (values nil ntp2)) |
1021 |
(cond ((eq ,tmp '*) t) |
(cond ((eq ,tmp '*) t) |
1022 |
((null ,tmp) t) |
((null ,tmp) t) |
1023 |
(t ,tmp)))))) |
(t ,tmp)))))) |
1024 |
(return-from subtypep (values (and (subtypep (ct car i1) (ct car i2)) |
(return-from osubtypep (values (and (osubtypep (ct car i1) (ct car i2)) |
1025 |
(subtypep (ct cadr i1) (ct cadr i2))) t)))) |
(osubtypep (ct cadr i1) (ct cadr i2))) t)))) |
1026 |
(t |
(t |
1027 |
(values nil ntp1)))) |
(values nil ntp1)))) |
1028 |
((eq t2 'list) |
((eq t2 'list) |
1194 |
(when (eq tp1 tp2) (return (values t t))))) |
(when (eq tp1 tp2) (return (values t t))))) |
1195 |
(t (values nil ntp2))))) |
(t (values nil ntp2))))) |
1196 |
((eq t2 'real) |
((eq t2 'real) |
1197 |
(cond ((and |
(let ((r (and (member t1 '(fixnum integer bignum float short-float |
1198 |
(member t1 '(fixnum integer bignum float short-float |
single-float double-float long-float |
1199 |
single-float double-float long-float |
real ratio |
1200 |
real ratio |
rational))))) |
1201 |
rational)) |
(values r r))) |
|
(sub-interval-p i1 i2)) |
|
|
(values t t)) |
|
|
(t (values nil ntp1)))) |
|
1202 |
((and (symbolp t2) (get t2 'si::s-data)) (values nil ntp1)) |
((and (symbolp t2) (get t2 'si::s-data)) (values nil ntp1)) |
1203 |
(t |
(t |
1204 |
(case t1 |
(case t1 |
1206 |
(case t2 |
(case t2 |
1207 |
(bignum (values t t)) |
(bignum (values t t)) |
1208 |
((integer rational) |
((integer rational) |
1209 |
(if (sub-interval-p '(* *) i2) |
(let ((r (sub-interval-p '(* *) i2))) |
1210 |
(values t t) |
(values r r))) |
|
(values nil t))) |
|
1211 |
(t (values nil ntp2)))) |
(t (values nil ntp2)))) |
1212 |
(ratio |
(ratio |
1213 |
(case t2 |
(case t2 |
1214 |
(rational |
(rational |
1215 |
(if (sub-interval-p '(* *) i2) (values t t) (values nil t))) |
(let ((r (sub-interval-p '(* *) i2))) (values r r))) |
1216 |
(t (values nil ntp2)))) |
(t (values nil ntp2)))) |
1217 |
(standard-char |
(standard-char |
1218 |
(if (member t2 '(base-char string-char character)) |
(if (member t2 '(base-char string-char character)) |
1236 |
(values nil ntp2))) |
(values nil ntp2))) |
1237 |
(integer |
(integer |
1238 |
(if (member t2 '(integer rational bignum)) |
(if (member t2 '(integer rational bignum)) |
1239 |
(values (sub-interval-p i1 i2) t) |
(let ((r (sub-interval-p i1 i2))) (values r r)) |
1240 |
(values nil ntp2))) |
(values nil ntp2))) |
1241 |
(rational |
(rational |
1242 |
(if (eq t2 'rational) |
(if (eq t2 'rational) |
1243 |
(values (sub-interval-p i1 i2) t) |
(let ((r (sub-interval-p i1 i2))) (values r r)) |
1244 |
(values nil ntp2))) |
(values nil ntp2))) |
1245 |
(float |
(float |
1246 |
(if (eq t2 'float) |
(if (eq t2 'float) |
1247 |
(values (sub-interval-p i1 i2) t) |
(let ((r (sub-interval-p i1 i2))) (values r r)) |
1248 |
(values nil ntp2))) |
(values nil ntp2))) |
1249 |
((short-float) |
((short-float) |
1250 |
(if (member t2 '(short-float float)) |
(if (member t2 '(short-float float)) |
1251 |
(values (sub-interval-p i1 i2) t) |
(let ((r (sub-interval-p i1 i2))) (values r r)) |
1252 |
(values nil ntp2))) |
(values nil ntp2))) |
1253 |
((single-float double-float long-float) |
((single-float double-float long-float) |
1254 |
(if (member t2 '(single-float double-float long-float float)) |
(if (member t2 '(single-float double-float long-float float)) |
1255 |
(values (sub-interval-p i1 i2) t) |
(let ((r (sub-interval-p i1 i2))) (values r r)) |
1256 |
(values nil ntp2))) |
(values nil ntp2))) |
1257 |
(complex |
(complex |
1258 |
(if (eq t2 'complex) |
(if (eq t2 'complex) |
1259 |
(subtypep (or (car i1) t) (or (car i2) t)) |
(osubtypep (or (car i1) t) (or (car i2) t)) |
1260 |
(values nil ntp2))) |
(values nil ntp2))) |
1261 |
((simple-array array) |
((simple-array array) |
1262 |
(cond ((or (eq t1 t2) (eq t2 'array)) |
(cond ((or (eq t1 t2) (eq t2 'array)) |
1264 |
(cond ((null b) c) |
(cond ((null b) c) |
1265 |
((eq (car b) s) (all-sym a s (cdr b) (1+ c))) |
((eq (car b) s) (all-sym a s (cdr b) (1+ c))) |
1266 |
(t a)))) |
(t a)))) |
1267 |
(macrolet ((ty (x) (let ((tmp (gensym))) |
(macrolet ((ty (x) `(or (car ,x) '*)) |
1268 |
`(or (not ,x) |
; (let ((tmp (gensym))) |
1269 |
(let ((,tmp (car ,x))) |
; `(or (not ,x) |
1270 |
(or (eq ,tmp '*) ,tmp))))) |
; (let ((,tmp (car ,x))) |
1271 |
|
; (or (eq ,tmp '*) ,tmp))))) |
1272 |
(di (x) (let ((tmp (gensym))) |
(di (x) (let ((tmp (gensym))) |
1273 |
`(or (not (cdr ,x)) |
`(or (not (cdr ,x)) |
1274 |
(let ((,tmp (cadr ,x))) |
(let ((,tmp (cadr ,x))) |
1278 |
(let* ((at1 (ty i1)) |
(let* ((at1 (ty i1)) |
1279 |
(at2 (ty i2)) |
(at2 (ty i2)) |
1280 |
(at2 (or (and (eq at2 'string-char) 'character) at2))) |
(at2 (or (and (eq at2 'string-char) 'character) at2))) |
1281 |
(unless (eq (upgraded-array-element-type at1) (upgraded-array-element-type at2)) |
(unless (or (eq at2 '*) |
1282 |
(return-from subtypep (values nil t)))) |
(eq (upgraded-array-element-type at1) (upgraded-array-element-type at2))) |
1283 |
|
(return-from osubtypep (values nil t)))) |
1284 |
(let ((ad1 (di i1)) |
(let ((ad1 (di i1)) |
1285 |
(ad2 (di i2))) |
(ad2 (di i2))) |
1286 |
(when (eq ad2 t) |
(when (eq ad2 t) |
1287 |
(return-from subtypep (values t t))) |
(return-from osubtypep (values t t))) |
1288 |
(when (eq ad1 t) |
(when (eq ad1 t) |
1289 |
(return-from subtypep (values nil t))) |
(return-from osubtypep (values nil t))) |
1290 |
(values (match-dimensions ad1 ad2) t))))) |
(values (match-dimensions ad1 ad2) t))))) |
1291 |
(t (values nil ntp2)))) |
(t (values nil ntp2)))) |
1292 |
(t (if ntp1 (values (eq t1 t2) t) (values nil nil))))))) |
(t (if ntp1 (values (eq t1 t2) t) (values nil nil))))))) |
1380 |
(return-from coerce object)) |
(return-from coerce object)) |
1381 |
(when (classp type) |
(when (classp type) |
1382 |
(specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type)) |
(specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type)) |
1383 |
(setq type (normalize-type type)) |
; (setq type (normalize-type type)) |
1384 |
|
(if (atom type) (setq type (list type))) |
1385 |
(case (car type) |
(case (car type) |
1386 |
|
; ((and or) (coerce object (cadr type)));FIXME!!! |
1387 |
(list |
(list |
1388 |
(do ((l nil (cons (elt object i) l)) |
(do ((l nil (cons (elt object i) l)) |
1389 |
(i (1- (length object)) (1- i))) |
(i (1- (length object)) (1- i))) |
1390 |
((< i 0) l))) |
((< i 0) l))) |
1391 |
((array simple-array) |
((array simple-array vector simple-vector string simple-string) |
1392 |
(unless (or (endp (cdr type)) |
(unless (or (endp (cdr type)) |
1393 |
(endp (cddr type)) |
(endp (cddr type)) |
1394 |
(eq (caddr type) '*) |
(eq (caddr type) '*) |
1395 |
(endp (cdr (caddr type)))) |
(endp (cdr (caddr type)))) |
1396 |
(specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type)) |
(specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type)) |
1397 |
(do ((seq (make-sequence type (length object))) |
(do ((seq (make-sequence type (length object))) |
1398 |
(i 0 (1+ i)) |
(i 0 (1+ i)) |
1399 |
(l (length object))) |
(l (length object))) |
1400 |
((>= i l) seq) |
((>= i l) seq) |
1401 |
(setf (elt seq i) (elt object i)))) |
(setf (elt seq i) (elt object i)))) |