224 |
(when (classp type) |
(when (classp type) |
225 |
(setq type (or (class-name type) |
(setq type (or (class-name type) |
226 |
(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)))) |
227 |
(when (typep-int object (normalize-type type)) |
(when (typep-int object (normalize-type-int type nil)) |
228 |
(return-from coerce object)) |
(return-from coerce object)) |
229 |
(if (atom type) (setq type (list type))) |
(if (atom type) (setq type (list type))) |
230 |
(case (car type) |
(case (car type) |
571 |
|
|
572 |
|
|
573 |
(defun resolve-type (type) |
(defun resolve-type (type) |
574 |
(nreconstruct-type (nprocess-type (normalize-type type t)))) |
(nreconstruct-type (nprocess-type (normalize-type-int type t)))) |
575 |
|
|
576 |
|
|
577 |
;;FIXME rethink need for side-effects here and in ntp functions above. |
(defun copy-type (type res) |
578 |
|
(cond ((atom type) (nreverse res)) |
579 |
|
((consp (car type)) (copy-type (cdr type) (cons (copy-type (car type) nil) res))) |
580 |
|
((member (car type) '(member eql)) type) |
581 |
|
((copy-type (cdr type) (cons (car type) res))))) |
582 |
|
|
583 |
(defun normalize-type (type &optional ar);FIXME |
(defun normalize-type (type &optional ar);FIXME |
584 |
(let ((type (if (atom type) type (copy-list type)))) |
(normalize-type-int type ar)) |
585 |
(normalize-type-int type ar))) |
|
586 |
|
(defmacro maybe-eval (x) `(if (and (consp ,x) (eq (car ,x) 'load-time-value)) (eval (cadr ,x)) ,x)) |
587 |
|
|
588 |
(defun normalize-type-int (type ar &aux tem) |
(defun normalize-type-int (type ar &aux tem) |
589 |
(cond ((atom type) (normalize-type-int (list type) ar)) |
(cond ((atom type) (normalize-type-int (list type) ar)) |
590 |
((setq tem (coerce-to-standard-class (car type))) (setf (car type) tem) type) |
;;These are deftype accelerators |
591 |
((classp (car type)) (normalize-type-int (setf (car type) (class-name (car type))) ar)) |
((member (car type) +range-types+) |
592 |
|
(let* ((l (cadr type)) |
593 |
|
(ln (if (cdr type) (maybe-eval l) '*)) |
594 |
|
(h (caddr type)) |
595 |
|
(hn (if (cddr type) (maybe-eval h) '*))) |
596 |
|
(if (and (eq l ln) (eq h hn)) type `(,(car type) ,ln ,hn)))) |
597 |
|
((eq (car type) 'complex) |
598 |
|
(let* ((z (cadr type)) |
599 |
|
(zn (if (cdr type) (maybe-eval z) 'real)) |
600 |
|
(zn (if (eq zn '*) 'real zn)) |
601 |
|
(zn (normalize-type-int zn ar))) |
602 |
|
(cond ((member (car zn) '(and or not)) (distribute-complex zn)) |
603 |
|
((and (not (cddr type)) (eq z zn)) type) |
604 |
|
(`(,(car type) ,zn))))) |
605 |
|
((member (car type) '(array simple-array)) |
606 |
|
(let* ((tp (cadr type)) |
607 |
|
(tpn (if (cdr type) (maybe-eval tp) '*)) |
608 |
|
(tpn (if ar (upgraded-array-element-type tpn) tpn)) |
609 |
|
(dm (caddr type)) |
610 |
|
(dmn (if (cddr type) (maybe-eval dm) '*)) |
611 |
|
(dmn (or dmn 0))) |
612 |
|
(if (and (not (cdddr type)) (eq tp tpn) (eq dm dmn)) type `(,(car type) ,tpn ,dmn)))) |
613 |
|
((eq (car type) 'member) type) |
614 |
|
((and (not (cdr type)) (member (car type) +singleton-types+)) type) |
615 |
|
((eq (car type) 'cons) |
616 |
|
(let* ((def '(t)) |
617 |
|
(car (cadr type)) |
618 |
|
(carn (if (cdr type) (maybe-eval car) def)) |
619 |
|
(carn (if (eq carn '*) def carn)) |
620 |
|
(carn (if (eq carn def) carn (normalize-type-int carn ar))) |
621 |
|
(cdr (caddr type)) |
622 |
|
(cdrn (if (cddr type) (maybe-eval cdr) def)) |
623 |
|
(cdrn (if (eq cdrn '*) def cdrn)) |
624 |
|
(cdrn (if (eq cdrn def) cdrn (normalize-type-int cdrn ar)))) |
625 |
|
(if (and (not (cdddr type)) (eq car carn) (eq cdr cdrn)) type `(,(car type) ,carn ,cdrn)))) |
626 |
|
((setq tem (coerce-to-standard-class (car type))) (if (eq (car type) tem) type `(,tem ,@(cdr type)))) |
627 |
|
((classp (car type)) (normalize-type-int `(,(class-name (car type)) ,@(cdr type)) ar)) |
628 |
((and (eq (car type) 'satisfies) |
((and (eq (car type) 'satisfies) |
629 |
(setq tem (get (cadr type) 'predicate-type))) |
(setq tem (get (cadr type) 'predicate-type))) |
630 |
(normalize-type-int tem ar)) |
(normalize-type-int tem ar)) |
631 |
((let* ((dt (and (symbolp (car type)) |
((let* ((dt (and (symbolp (car type)) |
632 |
(get (car type) 'deftype-definition))) |
(get (car type) 'deftype-definition))) |
633 |
(rr (do ((tmp (cdr type) (cdr tmp))) ((not tmp) (cdr type)) |
(rr (if (member 'load-time-value (cdr type) :key (lambda (x) (when (consp x) (car x)))) |
634 |
(when (and (consp (car tmp)) (eq (caar tmp) 'load-time-value)) |
(mapcar (lambda (x) (if (and (consp x) (eq (car x) 'load-time-value)) (eval (cadr x)) x)) |
635 |
(setf (car tmp) (eval (cadar tmp)))))) |
(cdr type)) |
636 |
|
(cdr type))) |
637 |
(nt (and dt (apply dt rr)))) |
(nt (and dt (apply dt rr)))) |
638 |
(when (and nt (not (equal type nt))) |
(when (and nt (not (equal type nt))) |
639 |
(normalize-type-int (copy-list nt) ar)))) |
(normalize-type-int nt ar)))) |
|
((and ar (member (car type) '(array simple-array))) |
|
|
(setf (cadr type) (upgraded-array-element-type (cadr type))) |
|
|
type) |
|
|
((eq (car type) 'complex) |
|
|
(distribute-complex (normalize-type-int (cadr type) ar))) |
|
|
((and (eq (car type) 'cons) (cdr type)) |
|
|
(setf (cadr type) (normalize-type-int (cadr type) ar)) |
|
|
(if (cddr type) |
|
|
(setf (caddr type) (normalize-type-int (caddr type) ar)) |
|
|
(setf (cddr type) `((t)))) |
|
|
(and (caadr type) (caaddr type) type)) |
|
640 |
((member (car type) '(and or not)) |
((member (car type) '(and or not)) |
641 |
(do ((tmp (cdr type) (cdr tmp))) ((not tmp)) |
(let ((type `(,(car type) ,@(mapcar (lambda (x) (normalize-type-int x ar)) (cdr type))))) |
|
(setf (car tmp) (normalize-type-int (car tmp) ar))) |
|
642 |
(if (cdr type) |
(if (cdr type) |
643 |
type |
type |
644 |
(case (car type) (and '(t)) (or '(nil)) (not (error "Bad type~%"))))) |
(case (car type) (and '(t)) (or '(nil)) (not (error "Bad type~%")))))) |
645 |
(type))) |
(type))) |
646 |
|
|
647 |
(defun distribute-complex (type) |
(defun distribute-complex (type) |