/[gcl]/gcl/ansi-tests/random-types.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/random-types.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by pfdietz, Tue Oct 7 07:38:32 2003 UTC revision 1.2 by pfdietz, Wed Nov 26 12:25:28 2003 UTC
# Line 58  Line 58 
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      

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26