58 |
(let ((nt1 `(not ,t1)) |
(let ((nt1 `(not ,t1)) |
59 |
(nt2 `(not ,t2))) |
(nt2 `(not ,t2))) |
60 |
(subtypep nt2 nt1)))))) |
(subtypep nt2 nt1)))))) |
61 |
|
|
62 |
|
(defun prune-type (tp try-fn) |
63 |
|
(declare (type function try-fn)) |
64 |
|
(flet ((try (x) (funcall try-fn x))) |
65 |
|
(cond |
66 |
|
((member tp '(nil t))) |
67 |
|
((symbolp tp) |
68 |
|
(try nil) |
69 |
|
(try t)) |
70 |
|
((consp tp) |
71 |
|
(try nil) |
72 |
|
(try t) |
73 |
|
(let ((op (first tp)) |
74 |
|
(args (rest tp))) |
75 |
|
(case op |
76 |
|
((cons) |
77 |
|
(try 'cons) |
78 |
|
(prune-list args |
79 |
|
#'prune-type |
80 |
|
#'(lambda (args) (try `(cons ,@args))))) |
81 |
|
((integer real float ratio single-float double-float short-float long-float) |
82 |
|
(try op)) |
83 |
|
((or and) |
84 |
|
(mapc try-fn args) |
85 |
|
(prune-list args |
86 |
|
#'prune-type |
87 |
|
#'(lambda (args) (try (cons op args))))) |
88 |
|
((not) |
89 |
|
(let ((arg (first args))) |
90 |
|
(try arg) |
91 |
|
(when (and (consp arg) |
92 |
|
(eq (car arg) 'not)) |
93 |
|
(try (second arg))) |
94 |
|
(prune-type arg #'(lambda (arg) (try `(not ,arg)))))) |
95 |
|
((member) |
96 |
|
(dolist (arg (cdr tp)) |
97 |
|
(try `(eql ,arg))) |
98 |
|
(when (cddr tp) |
99 |
|
(try `(member ,@(cddr tp))))) |
100 |
|
))))) |
101 |
|
(values)) |
102 |
|
|
103 |
|
(defun prune-type-pair (t1 t2) |
104 |
|
(let (changed) |
105 |
|
(loop |
106 |
|
do (flet ((%try2 (new-tp) |
107 |
|
(when (test-types t1 new-tp) |
108 |
|
(print "Success in first loop") |
109 |
|
(print new-tp) |
110 |
|
(setq t2 new-tp |
111 |
|
changed t) |
112 |
|
(throw 'success nil)))) |
113 |
|
(catch 'success |
114 |
|
(prune-type t2 #'%try2))) |
115 |
|
do (flet ((%try1 (new-tp) |
116 |
|
(when (test-types new-tp t2) |
117 |
|
(print "Success in second loop") |
118 |
|
(print new-tp) |
119 |
|
(setq t1 new-tp |
120 |
|
changed t) |
121 |
|
(throw 'success nil)))) |
122 |
|
(catch 'success |
123 |
|
(prune-type t1 #'%try1))) |
124 |
|
while changed |
125 |
|
do (setq changed nil))) |
126 |
|
(values t1 t2)) |
127 |
|
|
128 |
|
|
129 |
|
|
130 |
|
|
131 |
|
|
132 |
|
|
133 |
|
|
134 |
|
|
135 |
|
|