329 |
t |
t |
330 |
nil)) |
nil)) |
331 |
|
|
332 |
(defun implicit-symbol (x) |
(defun implicit-symbol (a b) |
333 |
(cond ((symbolp x) x) |
(cond ((not (consp a)) |
334 |
((consp x) |
(or (and (symbolp a) a) b)) |
335 |
(let ((is (car x))) |
((null b) |
336 |
(when (symbolp is) |
(let ((b (car a))) |
337 |
(dolist (y (cdr x) is) |
(and (symbolp b) (implicit-symbol (cdr a) b)))) |
338 |
(unless (or (eq y t) (eq y '*)) |
((let ((a (car a))) (or (eq a '*) (eq a t))) |
339 |
(return-from implicit-symbol nil)))))))) |
(implicit-symbol (cdr a) b)))) |
340 |
|
|
341 |
;;; SUBTYPEP predicate. |
;;; SUBTYPEP predicate. |
342 |
(defun subtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem) |
(defun subtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem) |
343 |
(declare (ignore env)) |
(declare (ignore env)) |
344 |
(let* ((c1 (classp type1)) (c2 (classp type2)) |
(let* ((c1 (classp type1)) (c2 (classp type2)) |
345 |
(t1 (if c1 type1 (let ((nt (implicit-symbol type1))) (and nt (find-class nt nil))))) |
(t1 (if c1 type1 (let ((nt (implicit-symbol type1 nil))) (and nt (find-class nt nil))))) |
346 |
(t2 (if c2 type2 (let ((nt (implicit-symbol type2))) (and nt (find-class nt nil)))))) |
(t2 (if c2 type2 (let ((nt (implicit-symbol type2 nil))) (and nt (find-class nt nil)))))) |
347 |
(when (and t1 t2) |
(when (and t1 t2) |
348 |
(return-from subtypep |
(return-from subtypep |
349 |
(if (member t2 (class-precedence-list t1)) |
(if (member t2 (class-precedence-list t1)) |
651 |
(values nil ntp2))) |
(values nil ntp2))) |
652 |
((simple-array array) |
((simple-array array) |
653 |
(cond ((or (eq t1 t2) (eq t2 'array)) |
(cond ((or (eq t1 t2) (eq t2 'array)) |
654 |
(macrolet ((ty (x) (let ((tmp (gensym))) |
(labels ((all-sym (a s &optional (b a) (c 0)) |
655 |
`(or (not ,x) |
(cond ((null b) c) |
656 |
(let ((,tmp (car ,x))) |
((eq (car b) s) (all-sym a s (cdr b) (1+ c))) |
657 |
(or (eq ,tmp '*) ,tmp))))) |
(t a)))) |
658 |
(di (x) (let ((tmp (gensym))) |
(macrolet ((ty (x) (let ((tmp (gensym))) |
659 |
`(or (not (cdr ,x)) |
`(or (not ,x) |
660 |
(let ((,tmp (cadr ,x))) |
(let ((,tmp (car ,x))) |
661 |
(or (eq ,tmp '*) |
(or (eq ,tmp '*) ,tmp))))) |
662 |
(and (consp ,tmp) ,tmp) |
(di (x) (let ((tmp (gensym))) |
663 |
(and (integerp ,tmp) |
`(or (not (cdr ,x)) |
664 |
(make-list ,tmp :initial-element '*)))))))) |
(let ((,tmp (cadr ,x))) |
665 |
(let* ((at1 (ty i1)) |
(or (eq ,tmp '*) |
666 |
(at2 (ty i2)) |
(and (integerp ,tmp) ,tmp) |
667 |
(at2 (or (and (eq at2 'string-char) 'character) at2))) |
(all-sym ,tmp '*))))))) |
668 |
(unless (equal at1 at2) |
(let* ((at1 (ty i1)) |
669 |
(return-from subtypep (values nil t)))) |
(at2 (ty i2)) |
670 |
(let ((ad1 (di i1)) |
(at2 (or (and (eq at2 'string-char) 'character) at2))) |
671 |
(ad2 (di i2))) |
(unless (equal at1 at2) |
672 |
(when (eq ad2 t) |
(return-from subtypep (values nil t)))) |
673 |
(return-from subtypep (values t t))) |
(let ((ad1 (di i1)) |
674 |
(when (eq ad1 t) |
(ad2 (di i2))) |
675 |
(return-from subtypep (values nil t))) |
(when (eq ad2 t) |
676 |
(values (match-dimensions ad1 ad2) t)))) |
(return-from subtypep (values t t))) |
677 |
|
(when (eq ad1 t) |
678 |
|
(return-from subtypep (values nil t))) |
679 |
|
(values (match-dimensions ad1 ad2) t))))) |
680 |
(t (values nil ntp2)))) |
(t (values nil ntp2)))) |
681 |
(t (if ntp1 (values (eq t1 t2) t) (values nil nil))))))) |
(t (if ntp1 (values (eq t1 t2) t) (values nil nil))))))) |
682 |
|
|
753 |
(defun match-dimensions (dim pat) |
(defun match-dimensions (dim pat) |
754 |
(cond ((null dim) |
(cond ((null dim) |
755 |
(null pat)) |
(null pat)) |
756 |
((not (consp dim)) |
((integerp dim) |
757 |
(eql dim pat)) |
(eql dim pat)) |
758 |
|
((integerp pat) |
759 |
|
(eql (length dim) pat)) |
760 |
(t |
(t |
761 |
(and (or (eq (car pat) '*) |
(and (or (eq (car pat) '*) |
762 |
(eql (car dim) (car pat))) |
(eql (car dim) (car pat))) |