1 ; Soft Scheme -- Copyright (C) 1993, 1994 Andrew K. Wright
3 ; This program is free software; you can redistribute it and/or modify
4 ; it under the terms of the GNU General Public License as published by
5 ; the Free Software Foundation; either version 2 of the License, or
6 ; (at your option) any later version.
8 ; This program is distributed in the hope that it will be useful,
9 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
10 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 ; GNU General Public License for more details.
13 ; You should have received a copy of the GNU General Public License
14 ; along with this program; if not, write to the Free Software
15 ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
17 ; Packaged as a single file for Larceny by Lars T Hansen.
18 ; Modified 2000-02-15 by lth.
22 ; The macro definitions for MATCH in this file depend on the presence of
23 ; certain helper functions in the compilation environment, eg. match:andmap.
24 ; (That is not a problem when loading this file, but it is an issue when
25 ; compiling it.) The easiest way to provide the helper functions during
26 ; compilation is to load match.sch into the compilation environment before
29 ; Once compiled, this program is self-contained.
31 ; The SoftScheme benchmark performs soft typing on a program and prints
32 ; a diagnostic report. All screen output is captured in an output
33 ; string port, which is subsequently discarded. (There is a moderate
34 ; amount of output). No file I/O occurs while the program is running.
36 (define (softscheme-benchmark)
37 (let ((expr `(begin ,@(readfile "ss-input.scm")))
38 (out (open-output-string)))
39 (run-benchmark "softscheme"
41 (with-output-to-port out
43 (soft-def expr #f)))))
45 (display (string-length (get-output-string out)))
46 (display " characters of output written.")
49 ;;; Define defmacro, macro?, and macroexpand-1.
56 (lambda (exp rename compare)
63 (if (not (and (list? exp)
66 (arglist? (caddr exp))))
67 (error "Bad macro definition: " exp))
68 (let ((name (cadr exp))
75 (lambda (_defmacro_exp
78 (apply (lambda ,args ,@body) (cdr _defmacro_exp)))))
82 (apply (lambda ,args ,@body) (cdr _exp))))
86 (define (macroexpand-1 exp)
88 (let ((probe (assq (car exp) *macros*)))
89 (if probe ((cdr probe) exp) exp)))
92 (define (macro? keyword)
93 (and (symbol? keyword) (assq keyword *macros*)))
95 ;;; Other compatibility hacks
97 (define slib:error error)
99 (define force-output flush-output-port)
102 (let ((format format))
103 (lambda (port . rest)
105 (let ((s (open-output-string)))
106 (apply format s rest)
107 (get-output-string s))
108 (apply format port rest)))))
111 (let ((gensym gensym)) (lambda () (gensym "G"))))
114 (let ((getenv getenv))
117 (if (string=? x "HOME")
118 "Ertevann:Desktop folder:"
121 ;;; The rest of the file should be more or less portable.
123 (define match-file #f)
124 (define installation-directory #f)
125 (define customization-file #f)
126 (define fastlibrary-file #f)
128 "Larceny Version 0.18, April 21, 1995")
129 (define match:version
130 "Version 1.18, July 17, 1995")
133 (for-each pretty-print args)
134 (slib:error "no matching clause for " val)))
139 (and (f (car l)) (match:andmap f (cdr l))))))
140 (define match:syntax-err
141 (lambda (obj msg) (slib:error msg obj)))
142 (define match:disjoint-structure-tags '())
143 (define match:make-structure-tag
145 (if (or (eq? match:structure-control 'disjoint)
146 match:runtime-structures)
147 (let ((tag (gentemp)))
148 (set! match:disjoint-structure-tags
149 (cons tag match:disjoint-structure-tags))
152 (string-append "<" (symbol->string name) ">")))))
153 (define match:structure?
155 (memq tag match:disjoint-structure-tags)))
156 (define match:structure-control 'vector)
157 (define match:set-structure-control
158 (lambda (v) (set! match:structure-control v)))
159 (define match:set-error
160 (lambda (v) (set! match:error v)))
161 (define match:error-control 'error)
162 (define match:set-error-control
163 (lambda (v) (set! match:error-control v)))
164 (define match:disjoint-predicates
173 (define match:vector-structures '())
174 (define match:expanders
176 (lambda (x clauses match-expr)
177 (let* ((length>= (gentemp))
178 (eb-errf (error-maker match-expr))
179 (blist (car eb-errf))
180 (plist (map (lambda (c)
181 (let* ((x (bound (validate-pattern
187 (fail (and (pair? (cdr c))
195 (bv2 (if fail (cons fail bv) bv))
196 (body (if fail (cddr c) (cdr c))))
198 (cons `(,code (lambda ,bv2 ,@body))
199 (append bindings blist)))
212 (unreachable plist match-expr)
215 (lambda (n) (lambda (l) (>= (length l) n))))
219 (lambda (pat exp body match-expr)
220 (let* ((length>= (gentemp))
221 (eb-errf (error-maker match-expr))
222 (x (bound (validate-pattern pat)))
227 (plist (list (list p code bv #f #f)))
235 (gs (map (lambda (_) (gentemp)) bv)))
236 (unreachable plist match-expr)
238 (lambda (n) (lambda (l) (>= (length l) n))))
239 ,@(map (lambda (v) `(,v #f)) bv)
243 ,@(map (lambda (v g) `(set! ,v ,g)) bv gs)
249 (lambda (pat exp match-expr)
250 (let* ((length>= (gentemp))
251 (eb-errf (error-maker match-expr))
252 (x (bound (validate-pattern pat)))
257 (plist (list (list p code bv #f #f)))
265 (gs (map (lambda (_) (gentemp)) bv)))
266 (unreachable plist match-expr)
268 ,@(map (lambda (v) `(define ,v #f)) bv)
271 (lambda (n) (lambda (l) (>= (length l) n))))
275 ,@(map (lambda (v g) `(set! ,v ,g)) bv gs)
303 (if (memq s '(... ___))
305 (let* ((s (symbol->string s)) (n (string-length s)))
307 (memq (string-ref s 0) '(#\. #\_))
308 (memq (string-ref s 1) '(#\. #\_))
311 (string->list (substring s 2 n)))
312 (string->number (substring s 2 n))))))))
315 (cond ((eq? match:error-control 'unspecified)
316 (cons '() (lambda (x) `(cond (#f #f)))))
317 ((memq match:error-control '(error fail))
318 (cons '() (lambda (x) `(match:error ,x))))
319 ((eq? match:error-control 'match)
320 (let ((errf (gentemp)) (arg (gentemp)))
323 (match:error ,arg ',match-expr))))
324 (lambda (x) `(,errf ,x)))))
327 '(unspecified error fail match)
328 "invalid value for match:error-control, legal values are")))))
330 (lambda (plist match-expr)
333 (if (not (car (cddddr x)))
335 (display "Warning: unreachable pattern ")
352 (let ((g88 (lambda (x y)
353 (cons (ordinary x) (ordinary y)))))
361 (if (equal? (car p) 'quasiquote)
362 (if (and (pair? (cdr p))
364 ((lambda (p) (quasi p)) (cadr p))
365 (g88 (car p) (cdr p)))
366 (if (equal? (car p) 'quote)
367 (if (and (pair? (cdr p))
370 (g88 (car p) (cdr p)))
371 (if (equal? (car p) '?)
372 (if (and (pair? (cdr p))
376 ,@(map ordinary ps)))
379 (g88 (car p) (cdr p)))
380 (if (equal? (car p) '=)
381 (if (and (pair? (cdr p))
385 `(= ,sel ,(ordinary p)))
388 (g88 (car p) (cdr p)))
389 (if (equal? (car p) 'and)
390 (if (and (list? (cdr p))
393 `(and ,@(map ordinary
396 (g88 (car p) (cdr p)))
397 (if (equal? (car p) 'or)
398 (if (and (list? (cdr p))
404 (g88 (car p) (cdr p)))
405 (if (equal? (car p) 'not)
406 (if (and (list? (cdr p))
409 `(not ,@(map ordinary
412 (g88 (car p) (cdr p)))
413 (if (equal? (car p) '$)
414 (if (and (pair? (cdr p))
424 (g88 (car p) (cdr p)))
428 (if (and (pair? (cdr p))
438 (if (and (pair? (cdr p))
455 (if (and (pair? (cdr p))
467 (cdr p)))))))))))))))
470 (let* ((pl (vector->list p))
473 (if (and (not (null? rpl))
480 (map ordinary pl)))))
485 "syntax error in pattern")))))))))))
487 (let ((g109 (lambda (x y)
488 (cons (quasi x) (quasi y)))))
492 ((lambda (p) `',p) p)
494 (if (equal? (car p) 'unquote)
495 (if (and (pair? (cdr p))
497 ((lambda (p) (ordinary p))
499 (g109 (car p) (cdr p)))
500 (if (and (pair? (car p))
507 ((lambda (p) (ordinary p))
515 (if (and (pair? (cdr p))
516 (dot-dot-k? (cadr p))
522 (g109 (car p) (cdr p)))))
525 (let* ((pl (vector->list p))
534 (map ordinary pl)))))
539 "syntax error in pattern"))))))))))
542 (cond ((null? p) '())
544 (cons (ordinary (car p)) (ordlist (cdr p))))
548 "invalid use of unquote-splicing in pattern"))))))
549 (ordinary pattern))))
550 (bound (lambda (pattern)
551 (letrec ((pred-bodies '())
552 (bound (lambda (p a k)
553 (cond ((eq? '_ p) (k p a))
558 "duplicate variable in pattern"))
561 (eq? 'quote (car p)))
563 ((and (pair? p) (eq? '? (car p)))
564 (cond ((not (null? (cddr p)))
565 (bound `(and (? ,(cadr p))
574 (cons `(,g ,(cadr p))
578 ((and (pair? p) (eq? '= (car p)))
579 (cond ((or (not (symbol?
584 (cons `(,g ,(cadr p))
586 (bound `(= ,g ,(caddr p))
596 ((and (pair? p) (eq? 'and (car p)))
602 ((and (pair? p) (eq? 'or (car p)))
605 (lambda (first-p first-a)
606 (let or* ((plist (cddr p))
617 (if (not (permutation
622 "variables of or-pattern differ in"))
627 ((and (pair? p) (eq? 'not (car p)))
628 (cond ((not (null? (cddr p)))
629 (bound `(not (or ,@(cdr p)))
636 (if (not (permutation
641 "no variables allowed in"))
646 (dot-dot-k? (cadr p)))
650 (let ((bvars (find-prefix
662 ((and (pair? p) (eq? '$ (car p)))
667 (k `($ ,(cadr p) ,@p1) a))))
670 (if (memq (cadr p) a)
672 (k p (cons (cadr p) a))))
675 (if (memq (cadr p) a)
677 (k p (cons (cadr p) a))))
693 (k (list->vector pl) a))))
697 (let ((g115 (lambda () (k plist a))))
699 (if (and (pair? (cdr plist))
700 (dot-dot-k? (cadr plist))
701 (null? (cddr plist)))
702 ((lambda () (bound plist a k)))
713 (k (cons car-p cdr-p)
719 (match:error plist))))))
731 (k (cons car-p cdr-p) a))))))))
736 (cons (car b) (find-prefix (cdr b) a)))))
739 (and (= (length p1) (length p2))
741 (lambda (x1) (memq x1 p2))
746 (list p (reverse a) pred-bodies))))))
749 (letrec ((occ (lambda (x e)
752 (+ (loop (car e)) (loop (cdr e))))
755 (subst (lambda (e old new)
758 (cons (loop (car e)) (loop (cdr e))))
770 (eq? (car sexp) 'quote)
772 (symbol? (cadr sexp))
773 (null? (cddr sexp))))))
786 (eq? (car sexp) 'lambda)
789 (const? (caddr sexp))
790 (null? (cdddr sexp)))))))
791 (let loop ((b (cadr let-exp))
795 (if (null? new-b) e `(let ,(reverse new-b) ,e)))
796 ((isval? (cadr (car b)))
797 (let* ((x (caar b)) (n (occ x e)))
798 (cond ((= 0 n) (loop (cdr b) new-b e))
799 ((or (= 1 n) (small? (cadr (car b))))
802 (subst e x (cadr (car b)))))
804 (loop (cdr b) (cons (car b) new-b) e)))))
805 (else (loop (cdr b) (cons (car b) new-b) e)))))))
806 (gen (lambda (x sf plist erract length>= eta)
810 (val (lambda (x) (cdr (assq x v))))
812 (gen x sf (cdr plist) erract length>= eta)))
815 (set-car! (cddddr (car plist)) #t)
816 (let* ((code (cadr (car plist)))
817 (bv (caddr (car plist)))
818 (fail-sym (cadddr (car plist))))
823 `(call-with-current-continuation
827 (,fail-sym ,(fail sf)))))
829 `(,code ,@(map val bv)))))))
830 (let next ((p (caar plist))
835 (cond ((eq? '_ p) (ks sf))
837 (set! v (cons (cons p e) v))
839 ((null? p) (emit `(null? ,e) sf kf ks))
840 ((equal? p ''()) (emit `(null? ,e) sf kf ks))
841 ((string? p) (emit `(equal? ,e ,p) sf kf ks))
842 ((boolean? p) (emit `(equal? ,e ,p) sf kf ks))
843 ((char? p) (emit `(equal? ,e ,p) sf kf ks))
844 ((number? p) (emit `(equal? ,e ,p) sf kf ks))
845 ((and (pair? p) (eq? 'quote (car p)))
846 (emit `(equal? ,e ,p) sf kf ks))
847 ((and (pair? p) (eq? '? (car p)))
848 (let ((tst `(,(cadr p) ,e)))
849 (emit tst sf kf ks)))
850 ((and (pair? p) (eq? '= (car p)))
851 (next (caddr p) `(,(cadr p) ,e) sf kf ks))
852 ((and (pair? p) (eq? 'and (car p)))
853 (let loop ((p (cdr p)) (sf sf))
860 (lambda (sf) (loop (cdr p) sf))))))
861 ((and (pair? p) (eq? 'or (car p)))
863 (let loop ((p (cdr p)) (sf sf))
871 (lambda (sf) (loop (cdr p) sf))
873 ((and (pair? p) (eq? 'not (car p)))
874 (next (cadr p) e sf ks kf))
875 ((and (pair? p) (eq? '$ (car p)))
876 (let* ((tag (cadr p))
878 (rlen (length fields))
879 (tst `(,(symbol-append tag '?) ,e)))
887 (next (list-ref fields n)
888 `(,(symbol-append tag '- n)
892 (rloop (+ 1 n)))))))))
893 ((and (pair? p) (eq? 'set! (car p)))
894 (set! v (cons (cons (cadr p) (setter e p)) v))
896 ((and (pair? p) (eq? 'get! (car p)))
897 (set! v (cons (cons (cadr p) (getter e p)) v))
901 (dot-dot-k? (cadr p)))
906 (let* ((k (dot-dot-k? (cadr p)))
908 (let ((bound (list-ref
911 (cond ((eq? (car p) '_)
914 (let* ((ptst (next (car p)
921 (tst (if (and (pair? ptst)
947 (let* ((gloop (list-ref
989 ((1) (emit `(pair? ,e) sf kf ks))
991 (emit `((,length>= ,k) ,e)
1011 (>= (vector-length p) 6)
1013 (vector-ref p (- (vector-length p) 5))))
1014 (let* ((vlen (- (vector-length p) 6))
1016 (vector-ref p (+ vlen 1))))
1018 (bound (vector-ref p (+ vlen 2))))
1023 (assm `(>= (vector-length ,e) ,minlen)
1027 (cond ((not (= n vlen))
1044 (let* ((gloop (vector-ref
1056 (p1 (next (vector-ref
1095 (let ((vlen (vector-length p)))
1109 (next (vector-ref p n)
1116 (display "FATAL ERROR IN PATTERN MATCHER")
1118 (error #f "THIS NEVER HAPPENS"))))))))
1119 (emit (lambda (tst sf kf ks)
1120 (cond ((in tst sf) (ks sf))
1121 ((in `(not ,tst) sf) (kf sf))
1123 (let* ((e (cadr tst))
1125 (cond ((eq? (car tst) 'equal?)
1126 (let ((p (caddr tst)))
1127 (cond ((string? p) `((string? ,e)))
1130 ((char? p) `((char? ,e)))
1131 ((number? p) `((number? ,e)))
1133 (eq? 'quote (car p)))
1136 ((eq? (car tst) 'null?) `((list? ,e)))
1137 ((vec-structure? tst) `((vector? ,e)))
1141 ((list?) `((not (null? ,e))))
1143 (s (ks (cons tst (append implied sf))))
1144 (k (kf (cons `(not ,tst)
1145 (append not-imp sf)))))
1147 (assm (lambda (tst f s)
1148 (cond ((equal? s f) s)
1149 ((and (eq? s #t) (eq? f #f)) tst)
1150 ((and (eq? (car tst) 'pair?)
1151 (memq match:error-control '(unspecified fail))
1152 (memq (car f) '(cond match:error))
1153 (guarantees s (cadr tst)))
1157 (equal? (cadddr s) f))
1158 (if (eq? (car (cadr s)) 'and)
1159 `(if (and ,tst ,@(cdr (cadr s))) ,(caddr s) ,f)
1160 `(if (and ,tst ,(cadr s)) ,(caddr s) ,f)))
1162 (equal? (car s) 'call-with-current-continuation)
1165 (equal? (caadr s) 'lambda)
1168 (null? (cdr (cadadr s)))
1170 (pair? (car (cddadr s)))
1171 (equal? (caar (cddadr s)) 'let)
1172 (pair? (cdar (cddadr s)))
1173 (pair? (cadar (cddadr s)))
1174 (pair? (caadar (cddadr s)))
1175 (pair? (cdr (caadar (cddadr s))))
1176 (pair? (cadr (caadar (cddadr s))))
1177 (equal? (caadr (caadar (cddadr s))) 'lambda)
1178 (pair? (cdadr (caadar (cddadr s))))
1179 (null? (cadadr (caadar (cddadr s))))
1180 (pair? (cddadr (caadar (cddadr s))))
1181 (pair? (car (cddadr (caadar (cddadr s)))))
1182 (pair? (cdar (cddadr (caadar (cddadr s)))))
1183 (null? (cddar (cddadr (caadar (cddadr s)))))
1184 (null? (cdr (cddadr (caadar (cddadr s)))))
1185 (null? (cddr (caadar (cddadr s))))
1186 (null? (cdadar (cddadr s)))
1187 (pair? (cddar (cddadr s)))
1188 (null? (cdddar (cddadr s)))
1189 (null? (cdr (cddadr s)))
1191 (equal? f (cadar (cddadr (caadar (cddadr s))))))
1192 (let ((k (car (cadadr s)))
1193 (fail (car (caadar (cddadr s))))
1194 (s2 (caddar (cddadr s))))
1195 `(call-with-current-continuation
1197 (let ((,fail (lambda () (,k ,f))))
1198 ,(assm tst `(,fail) s2))))))
1201 (equal? (car s) 'let)
1206 (pair? (car (cdaadr s)))
1207 (equal? (caar (cdaadr s)) 'lambda)
1208 (pair? (cdar (cdaadr s)))
1209 (null? (cadar (cdaadr s)))
1210 (pair? (cddar (cdaadr s)))
1211 (null? (cdddar (cdaadr s)))
1212 (null? (cdr (cdaadr s)))
1216 (equal? (caddar (cdaadr s)) f))
1217 (let ((fail (caaadr s)) (s2 (caddr s)))
1218 `(let ((,fail (lambda () ,f)))
1219 ,(assm tst `(,fail) s2))))
1220 (else `(if ,tst ,s ,f)))))
1223 (let ((a (add-a x)) (d (add-d x)))
1224 (let loop ((code code))
1225 (cond ((not (pair? code)) #f)
1226 ((memq (car code) '(cond match:error)) #t)
1227 ((or (equal? code a) (equal? code d)) #t)
1228 ((eq? (car code) 'if)
1229 (or (loop (cadr code))
1230 (and (loop (caddr code)) (loop (cadddr code)))))
1231 ((eq? (car code) 'lambda) #f)
1232 ((and (eq? (car code) 'let) (symbol? (cadr code)))
1234 (else (or (loop (car code)) (loop (cdr code)))))))))
1237 (and (eq? (car e) 'list?)
1238 (or (member `(null? ,(cadr e)) l)
1239 (member `(pair? ,(cadr e)) l)))
1240 (and (eq? (car e) 'not)
1241 (let* ((srch (cadr e))
1242 (const-class (equal-test? srch)))
1248 (or (and (equal? (cadr x) (cadr srch))
1257 (and (equal? (cadr x) (cadr srch))
1268 (or (and (equal? (cadr x) (cadr srch))
1274 ((eq? (car srch) 'list?)
1279 (or (and (equal? (cadr x) (cadr srch))
1285 ((vec-structure? srch)
1290 (or (and (equal? (cadr x) (cadr srch))
1301 `(not (vector? ,(cadr srch))))
1306 (and (eq? (car tst) 'equal?)
1307 (let ((p (caddr tst)))
1308 (cond ((string? p) 'string?)
1309 ((boolean? p) 'boolean?)
1311 ((number? p) 'number?)
1315 (eq? 'quote (car p))
1321 (memq (car tst) match:disjoint-predicates)))
1324 (memq (car tst) match:vector-structures)))
1326 (let ((new (and (pair? a) (assq (car a) c---rs))))
1327 (if new (cons (cadr new) (cdr a)) `(car ,a)))))
1329 (let ((new (and (pair? a) (assq (car a) c---rs))))
1330 (if new (cons (cddr new) (cdr a)) `(cdr ,a)))))
1334 (caar caaar . cdaar)
1335 (cadr caadr . cdadr)
1336 (cdar cadar . cddar)
1337 (cddr caddr . cdddr)
1338 (caaar caaaar . cdaaar)
1339 (caadr caaadr . cdaadr)
1340 (cadar caadar . cdadar)
1341 (caddr caaddr . cdaddr)
1342 (cdaar cadaar . cddaar)
1343 (cdadr cadadr . cddadr)
1344 (cddar caddar . cdddar)
1345 (cdddr cadddr . cddddr)))
1349 (lambda (s) (symbol-append 'set- s '!))))
1350 (cond ((not (pair? e))
1351 (match:syntax-err p "unnested set! pattern"))
1352 ((eq? (car e) 'vector-ref)
1353 `(let ((x ,(cadr e)))
1354 (lambda (y) (vector-set! x ,(caddr e) y))))
1355 ((eq? (car e) 'unbox)
1356 `(let ((x ,(cadr e))) (lambda (y) (set-box! x y))))
1358 `(let ((x ,(cadr e))) (lambda (y) (set-car! x y))))
1360 `(let ((x ,(cadr e))) (lambda (y) (set-cdr! x y))))
1361 ((let ((a (assq (car e) get-c---rs)))
1363 `(let ((x (,(cadr a) ,(cadr e))))
1364 (lambda (y) (,(mk-setter (cddr a)) x y))))))
1366 `(let ((x ,(cadr e)))
1367 (lambda (y) (,(mk-setter (car e)) x y))))))))
1370 (cond ((not (pair? e))
1371 (match:syntax-err p "unnested get! pattern"))
1372 ((eq? (car e) 'vector-ref)
1373 `(let ((x ,(cadr e)))
1374 (lambda () (vector-ref x ,(caddr e)))))
1375 ((eq? (car e) 'unbox)
1376 `(let ((x ,(cadr e))) (lambda () (unbox x))))
1378 `(let ((x ,(cadr e))) (lambda () (car x))))
1380 `(let ((x ,(cadr e))) (lambda () (cdr x))))
1381 ((let ((a (assq (car e) get-c---rs)))
1383 `(let ((x (,(cadr a) ,(cadr e))))
1384 (lambda () (,(cddr a) x))))))
1386 `(let ((x ,(cadr e))) (lambda () (,(car e) x)))))))
1400 (caaaar caaar . car)
1401 (caaadr caadr . car)
1402 (caadar cadar . car)
1403 (caaddr caddr . car)
1404 (cadaar cdaar . car)
1405 (cadadr cdadr . car)
1406 (caddar cddar . car)
1407 (cadddr cdddr . car)
1408 (cdaaar caaar . cdr)
1409 (cdaadr caadr . cdr)
1410 (cdadar cadar . cdr)
1411 (cdaddr caddr . cdr)
1412 (cddaar cdaar . cdr)
1413 (cddadr cdadr . cdr)
1414 (cdddar cddar . cdr)
1415 (cddddr cdddr . cdr)))
1419 (apply string-append
1421 (cond ((symbol? x) (symbol->string x))
1422 ((number? x) (number->string x))
1426 (if (null? (cdr l)) (car l) (rac (cdr l)))))
1430 (cons (car l) (rdc (cdr l)))))))
1431 (list genmatch genletrec gendefine pattern-var?)))
1435 (cond ((and (list? args)
1436 (<= 1 (length args))
1438 (lambda (y) (and (list? y) (<= 2 (length y))))
1440 (let* ((exp (car args))
1441 (clauses (cdr args))
1442 (e (if (symbol? exp) exp (gentemp))))
1444 ((car match:expanders) e clauses `(match ,@args))
1446 ,((car match:expanders) e clauses `(match ,@args))))))
1450 "syntax error in"))))
1454 (if (and (list? args)
1457 (if (and (pair? g126) (list? (cdr g126)))
1462 (let ((e (gentemp)))
1463 `(lambda (,e) (match ,e ,@args)))))
1466 `(match-lambda ,@args)
1467 "syntax error in")))))
1471 (if (and (list? args)
1474 (if (and (pair? g134) (list? (cdr g134)))
1479 (let ((e (gentemp)))
1480 `(lambda ,e (match ,e ,@args)))))
1483 `(match-lambda* ,@args)
1484 "syntax error in")))))
1488 (let ((g158 (lambda (pat exp body)
1489 `(match ,exp (,pat ,@body))))
1490 (g154 (lambda (pat exp body)
1491 (let ((g (map (lambda (x) (gentemp)) pat))
1492 (vpattern (list->vector pat)))
1493 `(let ,(map list g exp)
1494 (match (vector ,@g) (,vpattern ,@body))))))
1498 "syntax error in")))
1499 (g145 (lambda (p1 e1 p2 e2 body)
1500 (let ((g1 (gentemp)) (g2 (gentemp)))
1501 `(let ((,g1 ,e1) (,g2 ,e2))
1502 (match (cons ,g1 ,g2) ((,p1 unquote p2) ,@body))))))
1503 (g136 (cadddr match:expanders)))
1505 (if (symbol? (car args))
1506 (if (and (pair? (cdr args)) (list? (cadr args)))
1507 (let g161 ((g162 (cadr args)) (g160 '()) (g159 '()))
1509 (if (and (list? (cddr args)) (pair? (cddr args)))
1510 ((lambda (name pat exp body)
1511 (if (match:andmap (cadddr match:expanders) pat)
1513 `(letrec ((,name (match-lambda* (,pat ,@body))))
1520 (if (and (pair? (car g162))
1522 (null? (cddar g162)))
1524 (cons (cadar g162) g160)
1525 (cons (caar g162) g159))
1528 (if (list? (car args))
1531 (if (and (pair? g167)
1537 (if (and (list? (cdr args)) (pair? (cdr args)))
1538 ((lambda () `(let ,@args)))
1539 (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
1542 (if (and (pair? (car g150))
1544 (null? (cddar g150)))
1546 (cons (cadar g150) g148)
1547 (cons (caar g150) g147))
1549 (if (and (pair? (car args))
1551 (pair? (cdaar args))
1552 (null? (cddaar args)))
1553 (if (null? (cdar args))
1554 (if (and (list? (cdr args)) (pair? (cdr args)))
1555 (g158 (caaar args) (cadaar args) (cdr args))
1556 (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
1559 (if (and (pair? (car g150))
1561 (null? (cddar g150)))
1563 (cons (cadar g150) g148)
1564 (cons (caar g150) g147))
1566 (if (and (pair? (cdar args))
1567 (pair? (cadar args))
1568 (pair? (cdadar args))
1569 (null? (cdr (cdadar args)))
1570 (null? (cddar args)))
1571 (if (and (list? (cdr args)) (pair? (cdr args)))
1577 (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
1580 (if (and (pair? (car g150))
1582 (null? (cddar g150)))
1584 (cons (cadar g150) g148)
1585 (cons (caar g150) g147))
1587 (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
1589 (if (and (list? (cdr args)) (pair? (cdr args)))
1590 (g154 (reverse g147) (reverse g148) (cdr args))
1592 (if (and (pair? (car g150))
1594 (null? (cddar g150)))
1596 (cons (cadar g150) g148)
1597 (cons (caar g150) g147))
1599 (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
1601 (if (and (list? (cdr args)) (pair? (cdr args)))
1602 (g154 (reverse g147) (reverse g148) (cdr args))
1604 (if (and (pair? (car g150))
1606 (null? (cddar g150)))
1608 (cons (cadar g150) g148)
1609 (cons (caar g150) g147))
1611 (if (pair? (car args))
1612 (if (and (pair? (caar args))
1613 (pair? (cdaar args))
1614 (null? (cddaar args)))
1615 (if (null? (cdar args))
1616 (if (and (list? (cdr args)) (pair? (cdr args)))
1617 (g158 (caaar args) (cadaar args) (cdr args))
1618 (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
1621 (if (and (pair? (car g150))
1623 (null? (cddar g150)))
1625 (cons (cadar g150) g148)
1626 (cons (caar g150) g147))
1628 (if (and (pair? (cdar args))
1629 (pair? (cadar args))
1630 (pair? (cdadar args))
1631 (null? (cdr (cdadar args)))
1632 (null? (cddar args)))
1633 (if (and (list? (cdr args)) (pair? (cdr args)))
1639 (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
1642 (if (and (pair? (car g150))
1644 (null? (cddar g150)))
1646 (cons (cadar g150) g148)
1647 (cons (caar g150) g147))
1649 (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
1651 (if (and (list? (cdr args)) (pair? (cdr args)))
1652 (g154 (reverse g147) (reverse g148) (cdr args))
1654 (if (and (pair? (car g150))
1656 (null? (cddar g150)))
1658 (cons (cadar g150) g148)
1659 (cons (caar g150) g147))
1661 (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
1663 (if (and (list? (cdr args)) (pair? (cdr args)))
1664 (g154 (reverse g147) (reverse g148) (cdr args))
1666 (if (and (pair? (car g150))
1668 (null? (cddar g150)))
1670 (cons (cadar g150) g148)
1671 (cons (caar g150) g147))
1678 (let ((g176 (lambda ()
1680 `(match-let* ,@args)
1681 "syntax error in"))))
1683 (if (null? (car args))
1684 (if (and (list? (cdr args)) (pair? (cdr args)))
1685 ((lambda (body) `(let* ,@args)) (cdr args))
1687 (if (and (pair? (car args))
1689 (pair? (cdaar args))
1690 (null? (cddaar args))
1694 ((lambda (pat exp rest body)
1695 (if ((cadddr match:expanders) pat)
1696 `(let ((,pat ,exp)) (match-let* ,rest ,@body))
1697 `(match ,exp (,pat (match-let* ,rest ,@body)))))
1707 (let ((g200 (cadddr match:expanders))
1708 (g199 (lambda (p1 e1 p2 e2 body)
1710 (((,p1 unquote p2) (cons ,e1 ,e2)))
1714 `(match-letrec ,@args)
1715 "syntax error in")))
1716 (g194 (lambda (pat exp body)
1718 ((,(list->vector pat) (vector ,@exp)))
1720 (g186 (lambda (pat exp body)
1721 ((cadr match:expanders)
1725 `(match-letrec ((,pat ,exp)) ,@body)))))
1727 (if (list? (car args))
1730 (if (and (pair? g206)
1736 (if (and (list? (cdr args)) (pair? (cdr args)))
1737 ((lambda () `(letrec ,@args)))
1738 (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
1741 (if (and (pair? (car g190))
1743 (null? (cddar g190)))
1745 (cons (cadar g190) g188)
1746 (cons (caar g190) g187))
1748 (if (and (pair? (car args))
1750 (pair? (cdaar args))
1751 (null? (cddaar args)))
1752 (if (null? (cdar args))
1753 (if (and (list? (cdr args)) (pair? (cdr args)))
1754 (g186 (caaar args) (cadaar args) (cdr args))
1755 (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
1758 (if (and (pair? (car g190))
1760 (null? (cddar g190)))
1762 (cons (cadar g190) g188)
1763 (cons (caar g190) g187))
1765 (if (and (pair? (cdar args))
1766 (pair? (cadar args))
1767 (pair? (cdadar args))
1768 (null? (cdr (cdadar args)))
1769 (null? (cddar args)))
1770 (if (and (list? (cdr args)) (pair? (cdr args)))
1776 (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
1779 (if (and (pair? (car g190))
1781 (null? (cddar g190)))
1783 (cons (cadar g190) g188)
1784 (cons (caar g190) g187))
1786 (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
1788 (if (and (list? (cdr args)) (pair? (cdr args)))
1789 (g194 (reverse g187) (reverse g188) (cdr args))
1791 (if (and (pair? (car g190))
1793 (null? (cddar g190)))
1795 (cons (cadar g190) g188)
1796 (cons (caar g190) g187))
1798 (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
1800 (if (and (list? (cdr args)) (pair? (cdr args)))
1801 (g194 (reverse g187) (reverse g188) (cdr args))
1803 (if (and (pair? (car g190))
1805 (null? (cddar g190)))
1807 (cons (cadar g190) g188)
1808 (cons (caar g190) g187))
1810 (if (pair? (car args))
1811 (if (and (pair? (caar args))
1812 (pair? (cdaar args))
1813 (null? (cddaar args)))
1814 (if (null? (cdar args))
1815 (if (and (list? (cdr args)) (pair? (cdr args)))
1816 (g186 (caaar args) (cadaar args) (cdr args))
1817 (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
1820 (if (and (pair? (car g190))
1822 (null? (cddar g190)))
1824 (cons (cadar g190) g188)
1825 (cons (caar g190) g187))
1827 (if (and (pair? (cdar args))
1828 (pair? (cadar args))
1829 (pair? (cdadar args))
1830 (null? (cdr (cdadar args)))
1831 (null? (cddar args)))
1832 (if (and (list? (cdr args)) (pair? (cdr args)))
1838 (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
1841 (if (and (pair? (car g190))
1843 (null? (cddar g190)))
1845 (cons (cadar g190) g188)
1846 (cons (caar g190) g187))
1848 (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
1850 (if (and (list? (cdr args)) (pair? (cdr args)))
1851 (g194 (reverse g187) (reverse g188) (cdr args))
1853 (if (and (pair? (car g190))
1855 (null? (cddar g190)))
1857 (cons (cadar g190) g188)
1858 (cons (caar g190) g187))
1860 (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
1862 (if (and (list? (cdr args)) (pair? (cdr args)))
1863 (g194 (reverse g187) (reverse g188) (cdr args))
1865 (if (and (pair? (car g190))
1867 (null? (cddar g190)))
1869 (cons (cadar g190) g188)
1870 (cons (caar g190) g187))
1877 (let ((g210 (cadddr match:expanders))
1880 `(match-define ,@args)
1881 "syntax error in"))))
1883 (if (g210 (car args))
1884 (if (and (pair? (cdr args)) (null? (cddr args)))
1885 ((lambda () `(begin (define ,@args))))
1887 (if (and (pair? (cdr args)) (null? (cddr args)))
1889 ((caddr match:expanders)
1892 `(match-define ,@args)))
1897 (define match:runtime-structures #f)
1898 (define match:set-runtime-structures
1899 (lambda (v) (set! match:runtime-structures v)))
1900 (define match:primitive-vector? vector?)
1914 ((lambda () #f))))))
1923 ((lambda (s) s) (car x))
1933 ((lambda (s) s) (cadr x))
1935 (filter-map-with-index
1937 (letrec ((mapi (lambda (l i)
1938 (cond ((null? l) '())
1942 (cons x (mapi (cdr l) (+ 1 i)))))
1943 (else (mapi (cdr l) (+ 1 i)))))))
1945 (let ((g227 (lambda ()
1948 "syntax error in"))))
1949 (if (and (pair? args)
1950 (symbol? (car args))
1952 (symbol? (cadr args))
1954 (symbol? (caddr args))
1955 (list? (cdddr args)))
1956 (let g229 ((g230 (cdddr args)) (g228 '()))
1958 ((lambda (name constructor predicate fields)
1959 (let* ((selectors (map selector-name fields))
1960 (mutators (map mutator-name fields))
1961 (tag (if match:runtime-structures
1963 `',(match:make-structure-tag name)))
1965 (cond ((eq? match:structure-control 'disjoint)
1966 'match:primitive-vector?)
1967 ((eq? match:structure-control 'vector)
1969 (cond ((eq? match:structure-control 'disjoint)
1970 (if (eq? vector? match:primitive-vector?)
1973 (and (match:primitive-vector? v)
1974 (or (zero? (vector-length v))
1975 (not (symbol? (vector-ref v 0)))
1976 (not (match:structure?
1977 (vector-ref v 0))))))))
1978 (if (not (memq predicate match:disjoint-predicates))
1979 (set! match:disjoint-predicates
1980 (cons predicate match:disjoint-predicates))))
1981 ((eq? match:structure-control 'vector)
1982 (if (not (memq predicate match:vector-structures))
1983 (set! match:vector-structures
1984 (cons predicate match:vector-structures))))
1988 "invalid value for match:structure-control, legal values are")))
1990 ,@(if match:runtime-structures
1991 `((define ,tag (match:make-structure-tag ',name)))
1993 (define ,constructor
1994 (lambda ,selectors (vector ,tag ,@selectors)))
1998 (= (vector-length obj) ,(+ 1 (length selectors)))
1999 (eq? (vector-ref obj 0) ,tag))))
2000 ,@(filter-map-with-index
2002 `(define ,n (lambda (obj) (vector-ref obj ,i))))
2004 ,@(filter-map-with-index
2008 (lambda (obj newval)
2009 (vector-set! obj ,i newval)))))
2015 (if (field? (car g230))
2016 (g229 (cdr g230) (cons (car g230) g228))
2022 (let ((g242 (lambda ()
2024 `(define-structure ,@args)
2025 "syntax error in"))))
2026 (if (and (pair? args)
2028 (list? (cdar args)))
2029 (if (null? (cdr args))
2031 `(define-structure (,name ,@id1) ()))
2034 (if (and (pair? (cdr args)) (list? (cadr args)))
2035 (let g239 ((g240 (cadr args)) (g238 '()) (g237 '()))
2037 (if (null? (cddr args))
2038 ((lambda (name id1 id2 val)
2039 (let ((mk-id (lambda (id)
2041 (equal? (car id) '@)
2045 ((lambda (x) x) (cadr id))
2046 ((lambda () `(! ,id)))))))
2047 `(define-const-structure
2048 (,name ,@(map mk-id id1))
2049 ,(map (lambda (id v) `(,(mk-id id) ,v)) id2 val))))
2055 (if (and (pair? (car g240))
2057 (null? (cddar g240)))
2059 (cons (cadar g240) g238)
2060 (cons (caar g240) g237))
2065 define-const-structure
2072 (equal? (car id) '!)
2077 ((lambda () #f))))))
2079 (lambda (x) (if (symbol? x) x (cadr x))))
2080 (has-mutator? (lambda (x) (not (symbol? x))))
2081 (filter-map-with-index
2083 (letrec ((mapi (lambda (l i)
2084 (cond ((null? l) '())
2088 (cons x (mapi (cdr l) (+ 1 i)))))
2089 (else (mapi (cdr l) (+ 1 i)))))))
2094 (apply string-append
2096 (cond ((symbol? x) (symbol->string x))
2097 ((number? x) (number->string x))
2100 (let ((g266 (lambda ()
2102 `(define-const-structure ,@args)
2103 "syntax error in"))))
2104 (if (and (pair? args)
2106 (list? (cdar args)))
2107 (if (null? (cdr args))
2109 `(define-const-structure (,name ,@id1) ()))
2112 (if (symbol? (caar args))
2113 (let g259 ((g260 (cdar args)) (g258 '()))
2115 (if (and (pair? (cdr args)) (list? (cadr args)))
2116 (let g263 ((g264 (cadr args)) (g262 '()) (g261 '()))
2118 (if (null? (cddr args))
2119 ((lambda (name id1 id2 val)
2120 (let* ((id1id2 (append id1 id2))
2122 (symbol-append 'make-raw- name))
2123 (constructor (symbol-append 'make- name))
2124 (predicate (symbol-append name '?)))
2130 ,@(filter-map-with-index
2132 (if (has-mutator? arg)
2133 `(,(symbol-append name '- i)
2140 (symbol-append name '- i)))
2144 (if (eq? '_ x) (gentemp) x)))
2147 (map field-name id1)))
2150 (map field-name id2))))
2151 `(define ,constructor
2153 (let* ,(map list names2 val)
2157 ,@(filter-map-with-index
2159 (if (eq? (field-name field) '_)
2165 (field-name field)))
2166 ,(symbol-append name '- i))))
2168 ,@(filter-map-with-index
2170 (if (or (eq? (field-name field) '_)
2171 (not (has-mutator? field)))
2192 (if (and (pair? (car g264))
2193 (field? (caar g264))
2195 (null? (cddar g264)))
2197 (cons (cadar g264) g262)
2198 (cons (caar g264) g261))
2201 (if (field? (car g260))
2202 (g259 (cdr g260) (cons (car g260) g258))
2206 (define home-directory
2208 (error "environment variable HOME is not defined")))
2209 (defmacro recur args `(let ,@args))
2214 (((? symbol? x) v) `(letrec ((,x ,v)) ,x))))
2218 (match args ((bindings exp ...) `(begin ,@exp))))
2219 (define gensym gentemp)
2220 (define expand-once macroexpand-1)
2221 (defmacro check-increment-counter args #f)
2222 (define symbol-append
2225 (apply string-append
2226 (map (lambda (x) (format #f "~a" x)) l)))))
2227 (define gensym gentemp)
2230 (cond ((null? (car lists)) (and))
2231 ((null? (cdr (car lists)))
2232 (apply f (map car lists)))
2234 (and (apply f (map car lists))
2235 (apply andmap f (map cdr lists)))))))
2236 (define true-object? (lambda (x) (eq? #t x)))
2237 (define false-object? (lambda (x) (eq? #f x)))
2238 (define void (lambda () (cond (#f #f))))
2244 `(if ,tst (begin ,@body (void)) (void)))))
2250 `(if ,tst (void) (begin ,@body (void))))))
2251 (define should-never-reach
2253 (slib:error "fell off end of " form)))
2254 (define make-cvector make-vector)
2255 (define cvector vector)
2256 (define cvector-length vector-length)
2257 (define cvector-ref vector-ref)
2258 (define cvector->list vector->list)
2259 (define list->cvector list->vector)
2260 (define-const-structure (record _))
2265 ((((? symbol? id) exp) ...)
2267 (list ,@(map (lambda (i x) `(cons ',i ,x)) id exp))))
2268 (_ (slib:error "syntax error at " `(record ,@args)))))
2273 (((? symbol? id) exp)
2276 (match (assq ',id x)
2282 (cons 'record (map car x))))
2284 (_ (slib:error "not a record: " '(field ,id _)))))
2285 (_ (slib:error "syntax error at " `(field ,@args)))))
2286 (define-const-structure (module _))
2295 (record ,@(map (lambda (x) (list x x)) i)))))
2296 (_ (slib:error "syntax error at " `(module ,@args)))))
2301 ((((mod defs ...) ...) body __1)
2302 (let* ((m (map (lambda (_) (gentemp)) mod))
2304 (let loop ((mod-names m) (l-defs defs))
2305 (if (null? mod-names)
2308 (let ((m (car mod-names)))
2310 ((? symbol? x) `(,x (field ,x ,m)))
2311 (((? symbol? i) (? symbol? e))
2312 `(,i (field ,e ,m)))
2313 (x (slib:error "ill-formed definition: " x)))
2315 (loop (cdr mod-names) (cdr l-defs)))))))
2317 (map (lambda (m mod)
2318 `(,m (match ,mod (($ module x) x))))
2321 (let ,newdefs body ...))))))
2324 (slib:error "Unhandled exception " vals)))
2329 ((((x val) ...) body __1)
2330 (let ((old-x (map (lambda (_) (gentemp)) x))
2331 (swap-x (map (lambda (_) (gentemp)) x))
2333 `(let ,(map list old-x val)
2336 (let ,(map list swap-x old-x)
2337 ,@(map (lambda (old x) `(set! ,old ,x)) old-x x)
2338 ,@(map (lambda (x swap) `(set! ,x ,swap))
2341 (dynamic-wind ,swap (lambda () ,@body) ,swap)))))
2344 `(fluid-let ,@args)))))
2350 (let ((k (gentemp)) (exn (gentemp)))
2351 `((call-with-current-continuation
2354 ((raise (lambda ,exn (k (lambda () (apply ,h ,exn))))))
2355 (let ((v ,e)) (lambda () v))))))))
2356 (_ (slib:error "syntax error in " `(handle ,@args)))))
2360 (match args ((typeexp exp) exp)))
2365 ((((i type) ...) defs ...)
2370 ,@(map (lambda (i type) `(,i (: ,type ,i))) i type)))))))
2375 ((name type exp) `(define ,name (: ,type ,exp)))))
2377 (lambda (chk fmt . args)
2381 (string-append "~a : " fmt)
2389 (x (st:failure `(check-bound ,@x) "syntax-error"))))
2394 ((name info ...) name)
2395 (x (st:failure `(clash ,@x) "syntax error"))))
2400 (((id info ...) (? symbol? args) body __1)
2402 (check-increment-counter ,id)
2404 (((id info ...) args body __1)
2406 (chk (let loop ((a args) (nargs 0))
2407 (cond ((pair? a) (loop (cdr a) (+ 1 nargs)))
2410 `(= ,nargs (length args)))
2413 `(<= ,nargs (length args))))))
2414 (incr (if (number? id)
2415 `(check-increment-counter ,id)
2417 `(let ((lam (lambda ,args ,@body)))
2422 ,(if (eq? '= (car chk))
2424 '(check-lambda ,id ,@info)
2425 "requires ~a arguments, passed: ~a"
2429 '(check-lambda ,id ,@info)
2430 "requires >= ~a arguments, passed: ~a"
2433 (x (st:failure `(check-lambda ,@x) "syntax error"))))
2438 (((id info ...) (? symbol? f) args ...)
2440 (check-increment-counter ,id)
2444 '(check-ap ,id ,@info)
2445 "not a procedure: ~a"
2447 (((id info ...) f args ...)
2448 `((lambda (proc . args)
2449 (check-increment-counter ,id)
2450 (if (procedure? proc)
2453 '(check-ap ,id ,@info)
2454 "not a procedure: ~a"
2458 (x (st:failure `(check-ap ,@x) "syntax error"))))
2463 (((id info ...) (? symbol? f) exp)
2469 '(check-field ,id ,@info)
2470 "no ~a field in (record ~a)"
2475 '(check-field ,id ,@info)
2478 (x (st:failure `(check-field ,@x) "syntax error"))))
2483 (((id info ...) exp (and clause (pat _ __1)) ...)
2484 (letrec ((last (lambda (pl)
2485 (if (null? (cdr pl)) (car pl) (last (cdr pl))))))
2486 (if (match (last pat)
2488 (('and subp ...) (andmap symbol? subp))
2491 (check-increment-counter ,id)
2492 (match ,exp ,@clause))
2494 (check-increment-counter ,id)
2498 '(check-match ,id ,@info)
2499 "no matching clause for ~a"
2501 (x (st:failure `(check-match ,@x) "syntax error"))))
2506 (((id info ...) typeexp exp)
2508 '(check-: ,id ,@info)
2509 "static type annotation reached"))
2510 (x (st:failure `(check-: ,@x) "syntax error"))))
2516 (let ((chkprim (symbol-append 'check- prim)))
2522 (check-increment-counter (,'unquote (car id)))
2526 (cons ',chkprim '(,'unquote id))
2527 "invalid arguments: ~a"
2530 (let ((chkprim (symbol-append 'check- prim)))
2536 (check-increment-counter (,'unquote (car id)))
2537 (if (= 1 (length a))
2540 (cons ',chkprim '(,'unquote id))
2541 "invalid arguments: ~a"
2544 (let ((chkprim (symbol-append 'check- prim)))
2550 (check-increment-counter (,'unquote (car id)))
2551 (if (and (= 1 (length a)) (,type1 (car a)))
2554 (cons ',chkprim '(,'unquote id))
2555 "invalid arguments: ~a"
2558 (let ((chkprim (symbol-append 'check- prim)))
2564 (check-increment-counter (,'unquote (car id)))
2565 (if (= 2 (length a))
2566 (,prim (car a) (cadr a))
2568 (cons ',chkprim '(,'unquote id))
2569 "invalid arguments: ~a"
2572 (let ((chkprim (symbol-append 'check- prim)))
2578 (check-increment-counter (,'unquote (car id)))
2579 (if (and (= 2 (length a)) (,type2 (cadr a)))
2580 (,prim (car a) (cadr a))
2582 (cons ',chkprim '(,'unquote id))
2583 "invalid arguments: ~a"
2586 (let ((chkprim (symbol-append 'check- prim)))
2592 (check-increment-counter (,'unquote (car id)))
2593 (if (and (= 2 (length a)) (,type1 (car a)))
2594 (,prim (car a) (cadr a))
2596 (cons ',chkprim '(,'unquote id))
2597 "invalid arguments: ~a"
2600 (let ((chkprim (symbol-append 'check- prim)))
2606 (check-increment-counter (,'unquote (car id)))
2607 (if (and (= 2 (length a))
2610 (,prim (car a) (cadr a))
2612 (cons ',chkprim '(,'unquote id))
2613 "invalid arguments: ~a"
2616 (let ((nargs (length types))
2617 (chkprim (symbol-append 'check- prim))
2618 (types (map (match-lambda ('_ '(lambda (_) #t)) (x x))
2625 (check-increment-counter (,'unquote (car id)))
2626 (if (and (= ,nargs (length a))
2628 (lambda (f a) (f a))
2633 (cons ',chkprim '(,'unquote id))
2634 "invalid arguments: ~a"
2641 (let ((chkprim (symbol-append 'check- prim)))
2647 (check-increment-counter (,'unquote (car id)))
2651 (cons ',chkprim '(,'unquote id))
2652 "invalid arguments: ~a"
2654 (make-check-typed number? _)
2655 (make-check-typed null? _)
2656 (make-check-typed char? _)
2657 (make-check-typed symbol? _)
2658 (make-check-typed string? _)
2659 (make-check-typed vector? _)
2660 (make-check-typed box? _)
2661 (make-check-typed pair? _)
2662 (make-check-typed procedure? _)
2663 (make-check-typed eof-object? _)
2664 (make-check-typed input-port? _)
2665 (make-check-typed output-port? _)
2666 (make-check-typed true-object? _)
2667 (make-check-typed false-object? _)
2668 (make-check-typed boolean? _)
2669 (make-check-typed list? _)
2670 (make-check-typed not _)
2671 (make-check-typed eqv? _ _)
2672 (make-check-typed eq? _ _)
2673 (make-check-typed equal? _ _)
2674 (make-check-typed cons _ _)
2675 (make-check-selector car (x . _))
2676 (make-check-selector cdr (_ . x))
2677 (make-check-selector caar ((x . _) . _))
2678 (make-check-selector cadr (_ x . _))
2679 (make-check-selector cdar ((_ . x) . _))
2680 (make-check-selector cddr (_ _ . x))
2681 (make-check-selector caaar (((x . _) . _) . _))
2682 (make-check-selector caadr (_ (x . _) . _))
2683 (make-check-selector cadar ((_ x . _) . _))
2684 (make-check-selector caddr (_ _ x . _))
2685 (make-check-selector cdaar (((_ . x) . _) . _))
2686 (make-check-selector cdadr (_ (_ . x) . _))
2687 (make-check-selector cddar ((_ _ . x) . _))
2688 (make-check-selector cdddr (_ _ _ . x))
2689 (make-check-selector
2691 ((((x . _) . _) . _) . _))
2692 (make-check-selector
2694 (_ ((x . _) . _) . _))
2695 (make-check-selector
2697 ((_ (x . _) . _) . _))
2698 (make-check-selector caaddr (_ _ (x . _) . _))
2699 (make-check-selector
2701 (((_ x . _) . _) . _))
2702 (make-check-selector cadadr (_ (_ x . _) . _))
2703 (make-check-selector caddar ((_ _ x . _) . _))
2704 (make-check-selector cadddr (_ _ _ x . _))
2705 (make-check-selector
2707 ((((_ . x) . _) . _) . _))
2708 (make-check-selector
2710 (_ ((_ . x) . _) . _))
2711 (make-check-selector
2713 ((_ (_ . x) . _) . _))
2714 (make-check-selector cdaddr (_ _ (_ . x) . _))
2715 (make-check-selector
2717 (((_ _ . x) . _) . _))
2718 (make-check-selector cddadr (_ (_ _ . x) . _))
2719 (make-check-selector cdddar ((_ _ _ . x) . _))
2720 (make-check-selector cddddr (_ _ _ _ . x))
2721 (make-check-typed set-car! pair? _)
2722 (make-check-typed set-cdr! pair? _)
2727 (check-increment-counter ,(car id))
2729 (make-check-typed length list?)
2734 (check-increment-counter ,(car id))
2739 (((? list?) . y) (loop y))
2741 (cons 'check-append ',id)
2742 "invalid arguments: ~a"
2745 (make-check-typed reverse list?)
2746 (make-check-typed list-tail list? number?)
2747 (make-check-typed list-ref list? number?)
2748 (make-check-typed memq _ list?)
2749 (make-check-typed memv _ list?)
2750 (make-check-typed member _ list?)
2755 (check-increment-counter ,(car id))
2756 (if (and (= 2 (length a))
2758 (andmap pair? (cadr a)))
2759 (assq (car a) (cadr a))
2761 (cons 'check-assq ',id)
2762 "invalid arguments: ~a"
2768 (check-increment-counter ,(car id))
2769 (if (and (= 2 (length a))
2771 (andmap pair? (cadr a)))
2772 (assv (car a) (cadr a))
2774 (cons 'check-assv ',id)
2775 "invalid arguments: ~a"
2781 (check-increment-counter ,(car id))
2782 (if (and (= 2 (length a))
2784 (andmap pair? (cadr a)))
2785 (assoc (car a) (cadr a))
2787 (cons 'check-assoc ',id)
2788 "invalid arguments: ~a"
2790 (make-check-typed symbol->string symbol?)
2791 (make-check-typed string->symbol string?)
2792 (make-check-typed complex? _)
2793 (make-check-typed real? _)
2794 (make-check-typed rational? _)
2795 (make-check-typed integer? _)
2796 (make-check-typed exact? number?)
2797 (make-check-typed inexact? number?)
2802 (check-increment-counter ,(car id))
2803 (if (and (<= 2 (length a)) (andmap number? a))
2806 (cons 'check-= ',id)
2807 "invalid arguments: ~a"
2813 (check-increment-counter ,(car id))
2814 (if (and (<= 2 (length a)) (andmap number? a))
2817 (cons 'check-< ',id)
2818 "invalid arguments: ~a"
2824 (check-increment-counter ,(car id))
2825 (if (and (<= 2 (length a)) (andmap number? a))
2828 (cons 'check-> ',id)
2829 "invalid arguments: ~a"
2835 (check-increment-counter ,(car id))
2836 (if (and (<= 2 (length a)) (andmap number? a))
2839 (cons 'check-<= ',id)
2840 "invalid arguments: ~a"
2846 (check-increment-counter ,(car id))
2847 (if (and (<= 2 (length a)) (andmap number? a))
2850 (cons 'check->= ',id)
2851 "invalid arguments: ~a"
2853 (make-check-typed zero? number?)
2854 (make-check-typed positive? number?)
2855 (make-check-typed negative? number?)
2856 (make-check-typed odd? number?)
2857 (make-check-typed even? number?)
2862 (check-increment-counter ,(car id))
2863 (if (and (<= 1 (length a)) (andmap number? a))
2866 (cons 'check-max ',id)
2867 "invalid arguments: ~a"
2873 (check-increment-counter ,(car id))
2874 (if (and (<= 1 (length a)) (andmap number? a))
2877 (cons 'check-min ',id)
2878 "invalid arguments: ~a"
2884 (check-increment-counter ,(car id))
2885 (if (andmap number? a)
2888 (cons 'check-+ ',id)
2889 "invalid arguments: ~a"
2895 (check-increment-counter ,(car id))
2896 (if (andmap number? a)
2899 (cons 'check-* ',id)
2900 "invalid arguments: ~a"
2906 (check-increment-counter ,(car id))
2907 (if (and (<= 1 (length a)) (andmap number? a))
2910 (cons 'check-- ',id)
2911 "invalid arguments: ~a"
2917 (check-increment-counter ,(car id))
2918 (if (and (<= 1 (length a)) (andmap number? a))
2921 (cons 'check-/ ',id)
2922 "invalid arguments: ~a"
2924 (make-check-typed abs number?)
2925 (make-check-typed quotient number? number?)
2926 (make-check-typed remainder number? number?)
2927 (make-check-typed modulo number? number?)
2932 (check-increment-counter ,(car id))
2933 (if (andmap number? a)
2936 (cons 'check-gcd ',id)
2937 "invalid arguments: ~a"
2943 (check-increment-counter ,(car id))
2944 (if (andmap number? a)
2947 (cons 'check-lcm ',id)
2948 "invalid arguments: ~a"
2950 (make-check-typed numerator number?)
2951 (make-check-typed denominator number?)
2952 (make-check-typed floor number?)
2953 (make-check-typed ceiling number?)
2954 (make-check-typed truncate number?)
2955 (make-check-typed round number?)
2956 (make-check-typed rationalize number? number?)
2957 (make-check-typed exp number?)
2958 (make-check-typed log number?)
2959 (make-check-typed sin number?)
2960 (make-check-typed cos number?)
2961 (make-check-typed tan number?)
2962 (make-check-typed asin number?)
2963 (make-check-typed acos number?)
2968 (check-increment-counter ,(car id))
2969 (if (and (andmap number? a)
2974 (cons 'check-atan ',id)
2975 "invalid arguments: ~a"
2977 (make-check-typed sqrt number?)
2978 (make-check-typed expt number? number?)
2983 (make-check-typed make-polar number? number?)
2984 (make-check-typed real-part number?)
2985 (make-check-typed imag-part number?)
2986 (make-check-typed magnitude number?)
2987 (make-check-typed angle number?)
2988 (make-check-typed exact->inexact number?)
2989 (make-check-typed inexact->exact number?)
2991 check-number->string
2994 (check-increment-counter ,(car id))
2995 (if (and (andmap number? a)
2998 (apply number->string a)
3000 (cons 'check-number->string ',id)
3001 "invalid arguments: ~a"
3004 check-string->number
3007 (check-increment-counter ,(car id))
3011 (or (null? (cdr a)) (number? (cadr a))))
3012 (apply string->number a)
3014 (cons 'check-string->number ',id)
3015 "invalid arguments: ~a"
3017 (make-check-typed char=? char? char?)
3018 (make-check-typed char<? char? char?)
3019 (make-check-typed char>? char? char?)
3020 (make-check-typed char<=? char? char?)
3021 (make-check-typed char>=? char? char?)
3022 (make-check-typed char-ci=? char? char?)
3023 (make-check-typed char-ci<? char? char?)
3024 (make-check-typed char-ci>? char? char?)
3025 (make-check-typed char-ci<=? char? char?)
3026 (make-check-typed char-ci>=? char? char?)
3027 (make-check-typed char-alphabetic? char?)
3028 (make-check-typed char-numeric? char?)
3029 (make-check-typed char-whitespace? char?)
3030 (make-check-typed char-upper-case? char?)
3031 (make-check-typed char-lower-case? char?)
3032 (make-check-typed char->integer char?)
3033 (make-check-typed integer->char number?)
3034 (make-check-typed char-upcase char?)
3035 (make-check-typed char-downcase char?)
3040 (check-increment-counter ,(car id))
3044 (or (null? (cdr a)) (char? (cadr a))))
3045 (apply make-string a)
3047 (cons 'check-make-string ',id)
3048 "invalid arguments: ~a"
3054 (check-increment-counter ,(car id))
3055 (if (andmap char? a)
3058 (cons 'check-string ',id)
3059 "invalid arguments: ~a"
3061 (make-check-typed string-length string?)
3062 (make-check-typed string-ref string? number?)
3068 (make-check-typed string=? string? string?)
3069 (make-check-typed string<? string? string?)
3070 (make-check-typed string>? string? string?)
3071 (make-check-typed string<=? string? string?)
3072 (make-check-typed string>=? string? string?)
3073 (make-check-typed string-ci=? string? string?)
3074 (make-check-typed string-ci<? string? string?)
3075 (make-check-typed string-ci>? string? string?)
3076 (make-check-typed string-ci<=? string? string?)
3077 (make-check-typed string-ci>=? string? string?)
3087 (check-increment-counter ,(car id))
3088 (if (andmap string? a)
3089 (apply string-append a)
3091 (cons 'check-string-append ',id)
3092 "invalid arguments: ~a"
3094 (make-check-typed string->list string?)
3099 (check-increment-counter ,(car id))
3100 (if (and (= 1 (length a))
3102 (andmap char? (car a)))
3103 (list->string (car a))
3105 (cons 'check-list->string ',id)
3106 "invalid arguments: ~a"
3108 (make-check-typed string-copy string?)
3109 (make-check-typed string-fill! string? char?)
3110 (make-check-typed make-vector number? _)
3115 (check-increment-counter ,(car id))
3117 (make-check-typed vector-length vector?)
3118 (make-check-typed vector-ref vector? number?)
3119 (make-check-typed vector-set! vector? number? _)
3120 (make-check-typed vector->list vector?)
3121 (make-check-typed list->vector list?)
3122 (make-check-typed vector-fill! vector? _)
3127 (check-increment-counter ,(car id))
3129 (let loop ((arg (cdr a)))
3131 (((? list?)) (apply apply a))
3134 (cons 'check-apply ',id)
3135 "invalid arguments: ~a"
3139 "invalid arguments: ~a"
3145 (check-increment-counter ,(car id))
3146 (if (and (<= 2 (length a))
3147 (procedure? (car a))
3148 (andmap list? (cdr a)))
3151 (cons 'check-map ',id)
3152 "invalid arguments: ~a"
3158 (check-increment-counter ,(car id))
3159 (if (and (<= 2 (length a))
3160 (procedure? (car a))
3161 (andmap list? (cdr a)))
3164 (cons 'check-for-each ',id)
3165 "invalid arguments: ~a"
3167 (make-check-typed force procedure?)
3169 check-call-with-current-continuation
3172 (check-increment-counter ,(car id))
3173 (if (and (= 1 (length a)) (procedure? (car a)))
3174 (call-with-current-continuation
3176 ((car a) (check-lambda (continuation) (x) (k x)))))
3178 (cons 'check-call-with-current-continuation ',id)
3179 "invalid arguments: ~a"
3182 call-with-input-file
3186 call-with-output-file
3189 (make-check-typed input-port? _)
3190 (make-check-typed output-port? _)
3191 (make-check-typed current-input-port)
3192 (make-check-typed current-output-port)
3194 with-input-from-file
3201 (make-check-typed open-input-file string?)
3202 (make-check-typed open-output-file string?)
3203 (make-check-typed close-input-port input-port?)
3204 (make-check-typed close-output-port output-port?)
3209 (check-increment-counter ,(car id))
3211 (and (= 1 (length a)) (input-port? (car a))))
3214 (cons 'check-read ',id)
3215 "invalid arguments: ~a"
3221 (check-increment-counter ,(car id))
3223 (and (= 1 (length a)) (input-port? (car a))))
3226 (cons 'check-read-char ',id)
3227 "invalid arguments: ~a"
3233 (check-increment-counter ,(car id))
3235 (and (= 1 (length a)) (input-port? (car a))))
3238 (cons 'check-peek-char ',id)
3239 "invalid arguments: ~a"
3245 (check-increment-counter ,(car id))
3247 (and (= 1 (length a)) (input-port? (car a))))
3248 (apply char-ready? a)
3250 (cons 'check-char-ready? ',id)
3251 "invalid arguments: ~a"
3257 (check-increment-counter ,(car id))
3259 (or (null? (cdr a)) (output-port? (cadr a))))
3262 (cons 'check-write ',id)
3263 "invalid arguments: ~a"
3269 (check-increment-counter ,(car id))
3271 (or (null? (cdr a)) (output-port? (cadr a))))
3274 (cons 'check-display ',id)
3275 "invalid arguments: ~a"
3281 (check-increment-counter ,(car id))
3282 (if (or (null? a) (output-port? (car a)))
3285 (cons 'check-newline ',id)
3286 "invalid arguments: ~a"
3292 (check-increment-counter ,(car id))
3295 (or (null? (cdr a)) (output-port? (cadr a))))
3296 (apply write-char a)
3298 (cons 'check-write-char ',id)
3299 "invalid arguments: ~a"
3301 (make-check-typed load string?)
3302 (make-check-typed transcript-on string?)
3303 (make-check-typed transcript-off)
3308 (check-increment-counter ,(car id))
3309 (apply symbol-append a)))
3310 (make-check-typed box _)
3311 (make-check-typed unbox box?)
3312 (make-check-typed set-box! box? _)
3313 (make-check-typed void)
3314 (make-check-typed make-module _)
3319 (check-increment-counter ,(car id))
3321 (apply match:error a)
3323 (cons 'check-match:error ',id)
3324 "invalid arguments: ~a"
3326 (make-check-typed should-never-reach symbol?)
3331 (check-increment-counter ,(car id))
3335 (apply make-cvector a)
3337 (cons 'check-make-cvector ',id)
3338 "invalid arguments: ~a"
3344 (check-increment-counter ,(car id))
3346 (make-check-typed cvector-length cvector?)
3347 (make-check-typed cvector-ref cvector? number?)
3348 (make-check-typed cvector->list cvector?)
3349 (make-check-typed list->cvector list?)
3351 check-define-const-structure
3360 (null? (cddr x))))))
3362 (lambda (x) (if (symbol? x) x (cadr x))))
3363 (with-mutator? (lambda (x) (not (symbol? x)))))
3365 ((((? symbol? name) (? field? id1) ...))
3366 (let ((constructor (symbol-append 'make- name))
3368 (symbol-append 'check-make- name))
3369 (predicate (symbol-append name '?))
3372 (cond ((null? l) '())
3373 ((eq? '_ (arg-name (car l))) (loop (cdr l)))
3375 (cons (symbol-append name '- (arg-name (car l)))
3379 (cond ((null? l) '())
3380 ((eq? '_ (arg-name (car l))) (loop (cdr l)))
3381 ((not (with-mutator? (car l))) (loop (cdr l)))
3383 (cons (symbol-append
3390 (nargs (length id1)))
3392 (define-const-structure (,name ,@id1) ())
3397 (check-increment-counter (,'unquote (car id)))
3398 (if (= ,nargs (length a))
3399 (apply ,constructor a)
3401 (cons ',check-constructor '(,'unquote id))
3402 "invalid arguments: ~a"
3404 (make-check-typed ,predicate _)
3405 ,@(map (lambda (a) `(make-check-typed ,a ,predicate))
3407 ,@(map (lambda (a) `(make-check-typed ,a ,predicate _))
3410 `(check-define-const-structure ,@x)
3412 (if (equal? '(match 1) (macroexpand-1 '(match 1)))
3413 (load "/home/wright/scheme/match/match-slib.scm"))
3415 (lambda args (apply format #f args)))
3417 (lambda args (apply format #t args)))
3419 (lambda (context fmt . args)
3422 (string-append "in ~a: " fmt)
3426 (lambda (fmt . args)
3427 (slib:error (apply sprintf fmt args))))
3429 (lambda (context fmt . args)
3431 (if context (pretty-print context))
3434 (string-append "in syntax: " fmt)
3436 (define flush-output force-output)
3437 (define print-context
3444 (cons (loop (car obj) (+ 1 n))
3448 (define *box-tag* (gensym))
3449 (define box (lambda (a) (cons *box-tag* a)))
3452 (and (pair? b) (eq? (car b) *box-tag*))))
3455 (define set-box! set-cdr!)
3456 (define sort-list sort)
3457 (define expand-once-if-macro
3459 (and (macro? (car e)) (macroexpand-1 e))))
3462 (if (null? (car lists))
3464 (or (apply f (map car lists))
3465 (apply ormap f (map cdr lists))))))
3466 (define call/cc call-with-current-continuation)
3467 (define (cpu-time) 0)
3468 (define (pretty-print x) (display x) (newline))
3469 (define clock-granularity 1.0e-3)
3470 (define set-vector! vector-set!)
3471 (define set-string! string-set!)
3476 ((x . y) (let ((v (f x))) (cons v (maplr f y)))))))
3481 ((x . y) (let ((v (maprl f y))) (cons (f x) v))))))
3486 (match l (() acc) ((x . y) (loop y (f x acc)))))))
3491 (match l (() i) ((x . y) (f x (loop y)))))))
3497 (if (p x) (cons x (filter p y)) (filter p y))))))
3504 (#f (filter-map p y))
3505 (x (cons x (filter-map p y))))))))
3508 (match l ((last) last) ((_ . rest) (rac rest)))))
3513 ((x . rest) (cons x (rdc rest))))))
3521 (let ((v (f x n))) (cons v (loop y (+ 1 n)))))))))
3524 (with-input-from-file
3526 (letrec ((rf (lambda ()
3528 ((? eof-object?) '())
3529 (sexp (cons sexp (rf)))))))
3535 (((ax . ay) bx . by)
3536 (let ((v (f ax bx))) (cons v (map2 f ay by))))
3537 (else (error 'map2 "lists differ in length")))))
3542 (((ax . ay) bx . by)
3544 (for-each2 f ay by))
3545 (else (error 'for-each2 "lists differ in length")))))
3550 (((ax) bx) (f ax bx))
3551 (((ax . ay) bx . by)
3552 (and (f ax bx) (andmap2 f ay by)))
3553 (else (error 'andmap2 "lists differ in length")))))
3558 (((ax) bx) (f ax bx))
3559 (((ax . ay) bx . by)
3560 (or (f ax bx) (ormap2 f ay by)))
3561 (else (error 'ormap2 "lists differ in length")))))
3562 (define empty-set '())
3563 (define empty-set? null?)
3564 (define set (lambda l (list->set l)))
3571 (cons x (list->set y))))))
3573 (lambda (x set) (and (memq x set) #t)))
3574 (define cardinality length)
3577 (foldr (lambda (a-elt acc) (and acc (memq a-elt b) #t))
3582 (and (= (cardinality a) (cardinality b))
3588 (foldr (lambda (x b) (if (memq x b) b (cons x b)))
3591 (define union (lambda l (foldr union2 '() l)))
3596 (foldr (lambda (x c) (if (memq x b) c (cons x c)))
3603 (setdiff2 (car l) (foldr union2 '() (cdr l))))))
3608 (foldr (lambda (x c) (if (memq x b) (cons x c) c))
3613 (if (null? l) '() (foldl intersect2 (car l) l))))
3614 (define-const-structure (some _))
3615 (define-const-structure (none))
3616 (define none (make-none))
3617 (define some make-some)
3618 (define-const-structure (and exps))
3619 (define-const-structure (app exp exps))
3620 (define-const-structure (begin exps))
3621 (define-const-structure (const val pred))
3622 (define-const-structure (if exp1 exp2 exp3))
3623 (define-const-structure (lam names body))
3624 (define-const-structure (let binds body))
3625 (define-const-structure (let* binds body))
3626 (define-const-structure (letr binds body))
3627 (define-const-structure (or exps))
3628 (define-const-structure (prim name))
3629 (define-const-structure (delay exp))
3630 (define-const-structure (set! (! name) exp))
3631 (define-const-structure (var (! name)))
3632 (define-const-structure (vlam names name body))
3633 (define-const-structure (match exp mclauses))
3634 (define-const-structure (record binds))
3635 (define-const-structure (field name exp))
3636 (define-const-structure (cast type exp))
3637 (define-const-structure (body defs exps))
3638 (define-const-structure (bind name exp))
3639 (define-const-structure (mclause pat body fail))
3640 (define-const-structure (pvar name))
3641 (define-const-structure (pany))
3642 (define-const-structure (pelse))
3643 (define-const-structure (pconst name pred))
3644 (define-const-structure (pobj name pats))
3645 (define-const-structure (ppred name))
3646 (define-const-structure (pand pats))
3647 (define-const-structure (pnot pat))
3648 (define-const-structure (define name (! exp)))
3649 (define-const-structure
3660 (define-const-structure (datatype _))
3661 (define-const-structure
3662 (variant con pred arg-types))
3676 (define-structure (type ty exp))
3677 (define-const-structure (shape _ _))
3678 (define-const-structure (check _ _))
3685 (syntax-err def "invalid use of keyword ~a" s)
3687 (n (syntax-err def "invalid variable at ~a" n)))))
3689 (('extend-syntax ((? symbol? name) . _) . _)
3691 "Note: installing but _not_ checking (extend-syntax (~a) ...)~%"
3695 (('extend-syntax . _)
3696 (syntax-err def "invalid syntax"))
3697 (('defmacro (? symbol? name) . _)
3699 "Note: installing but _not_ checking (defmacro ~a ...)~%"
3704 (syntax-err def "invalid syntax"))
3705 (('define (? symbol? n) e)
3706 (list (make-define (parse-name n) (parse-exp e))))
3707 (('define (n . args) . body)
3710 (parse-exp `(lambda ,args ,@body)))))
3711 (('define . _) (syntax-err def "at define"))
3713 (foldr append '() (smap parse-def defs)))
3714 (('define-structure (n . args))
3715 (parse-def `(define-structure (,n ,@args) ())))
3716 (('define-structure (n . args) inits)
3717 (let ((m-args (smap (lambda (x) `(! ,x)) args))
3720 ((x e) `((! ,x) ,e))
3723 "invalid structure initializer")))
3726 `(define-const-structure (,n ,@m-args) ,m-inits))))
3727 (('define-const-structure ((? symbol? n) . args))
3729 `(define-const-structure (,n ,@args) ())))
3730 (('define-const-structure
3731 ((? symbol? n) . args)
3733 (letrec ((smap-with-n
3741 (cons v (loop y (+ 1 n)))))
3742 (_ (syntax-err l "invalid list"))))))
3749 (some (symbol-append
3753 (some (symbol-append
3761 (let ((a (parse-name a)))
3762 (list (some (symbol-append n '- a))
3763 (some (symbol-append
3769 (some (symbol-append
3773 (some (symbol-append
3783 (some (symbol-append
3789 (a (let ((a (parse-name a)))
3790 (list (some (symbol-append n '- a))
3792 (some (symbol-append
3798 (let* ((arg-info (smap-with-n parse-arg args))
3799 (get (map car arg-info))
3800 (set (map cadr arg-info))
3801 (getn (map caddr arg-info))
3802 (setn (map cadddr arg-info))
3804 (map (lambda (x) (car (cddddr x))) arg-info)))
3805 (list (make-defstruct
3808 (symbol-append 'make- n)
3809 (symbol-append n '?)
3815 (('define-const-structure
3816 ((? symbol? n) . args)
3820 "sorry, structure initializers are not supported"))
3822 (let* ((parse-variant
3824 (((? symbol? con) ? list? args)
3825 (let ((n (parse-name con)))
3827 (symbol-append 'make- n)
3828 (symbol-append n '?)
3830 (_ (syntax-err def "invalid datatype syntax"))))
3833 (((? symbol? type) . variants)
3834 (cons (list (parse-name type))
3835 (smap parse-variant variants)))
3836 ((((? symbol? type) ? list? targs) . variants)
3837 (cons (cons (parse-name type)
3838 (smap parse-name targs))
3839 (smap parse-variant variants)))
3840 (_ (syntax-err def "invalid datatype syntax")))))
3841 (list (make-datatype (smap parse-dt d)))))
3842 (((? symbol? k) . _)
3843 (cond ((and (not (keyword? k))
3844 (expand-once-if-macro def))
3847 (else (list (make-define #f (parse-exp def))))))
3848 (_ (list (make-define #f (parse-exp def))))))))
3849 (define keep-match #t)
3851 (lambda (expression)
3852 (letrec ((n-primitive (string->symbol "#primitive"))
3855 (('quote (? symbol? s)) (make-const s 'symbol?))
3856 ((and m ('quote _)) (parse-exp (quote-tf m)))
3857 ((and m ('quasiquote _))
3858 (parse-exp (quasiquote-tf m)))
3859 ((and m (? box?)) (parse-exp (quote-tf m)))
3860 ((and m (? vector?)) (parse-exp (quote-tf m)))
3861 ((and m ('cond . _)) (parse-exp (cond-tf m)))
3862 ((and m ('case . _)) (parse-exp (case-tf m)))
3863 ((and m ('do . _)) (parse-exp (do-tf m)))
3864 ((? symbol? s) (make-var (parse-name s)))
3865 (#t (make-const #t 'true-object?))
3866 (#f (make-const #f 'false-object?))
3867 ((? null? c) (make-const c 'null?))
3868 ((? number? c) (make-const c 'number?))
3869 ((? char? c) (make-const c 'char?))
3870 ((? string? c) (make-const c 'string?))
3871 ((': ty e1) (make-cast ty (parse-exp e1)))
3872 ((and exp ('record . bind))
3873 (let ((bindings (smap parse-bind bind)))
3874 (no-repeats (map bind-name bindings) exp)
3875 (make-record bindings)))
3876 ((and exp ('field name e1))
3877 (make-field (parse-name name) (parse-exp e1)))
3878 ((and exp ('match e clause0 . clauses))
3881 (let* ((e2 (parse-exp e))
3884 ((p ('=> (? symbol? failsym)) . body)
3886 (parse-pat p expression)
3888 `((let ((,failsym (lambda () (,failsym))))
3893 (parse-pat p expression)
3896 (_ (syntax-err exp "invalid match clause")))))
3899 (smap parse-clause (cons clause0 clauses))))
3901 ((and exp ('lambda bind . body))
3903 ((b bind) (names '()))
3906 (let ((rest (parse-name n)))
3907 (no-repeats (cons rest names) exp)
3911 (parse-body body))))
3913 (no-repeats names exp)
3914 (make-lam (reverse names) (parse-body body)))
3915 ((n . x) (loop x (cons (parse-name n) names)))
3918 "invalid lambda expression")))))
3924 ((and if-expr ('if e1 e2))
3925 (printf "Note: one-armed if: ")
3926 (print-context if-expr 2)
3930 (parse-exp '(void))))
3931 (('delay e) (make-delay (parse-exp e)))
3933 (make-set! (parse-name n) (parse-exp e)))
3934 (('and . args) (make-and (smap parse-exp args)))
3935 (('or . args) (make-or (smap parse-exp args)))
3936 ((and exp ('let (? symbol? n) bind . body))
3937 (let* ((nb (parse-name n))
3938 (bindings (smap parse-bind bind)))
3939 (no-repeats (map bind-name bindings) exp)
3945 (map bind-name bindings)
3946 (parse-body body))))
3947 (make-body '() (list (make-var nb))))
3948 (map bind-exp bindings))))
3949 ((and exp ('let bind . body))
3950 (let ((bindings (smap parse-bind bind)))
3951 (no-repeats (map bind-name bindings) exp)
3952 (make-let bindings (parse-body body))))
3953 (('let* bind . body)
3955 (smap parse-bind bind)
3957 ((and exp ('letrec bind . body))
3958 (let ((bindings (smap parse-bind bind)))
3959 (no-repeats (map bind-name bindings) exp)
3960 (make-letr bindings (parse-body body))))
3962 (make-begin (smap parse-exp (cons e1 rest))))
3966 "invalid context for internal define"))
3967 (('define-structure . _)
3970 "invalid context for internal define-structure"))
3971 (('define-const-structure . _)
3974 "invalid context for internal define-const-structure"))
3976 (cond ((and (eq? f n-primitive)
3978 (((? symbol? p)) (make-prim p))
3982 (expand-once-if-macro m))
3986 (make-app (parse-exp f) (smap parse-exp args)))))
3989 "invalid expression at ~a"
3997 "invalid use of keyword ~a"
4002 "invalid variable at ~a"
4006 ((x e) (make-bind (parse-name x) (parse-exp e)))
4007 (b (syntax-err expression "invalid binding at ~a" b))))
4011 ((b body) (defs '()))
4013 (((and d ('define . _)) . rest)
4014 (loop rest (append defs (parse-def d))))
4015 (((and d ('define-structure . _)) . rest)
4016 (loop rest (append defs (parse-def d))))
4017 (((and d ('define-const-structure . _)) . rest)
4018 (loop rest (append defs (parse-def d))))
4019 ((('begin) . rest) (loop rest defs))
4020 (((and beg ('begin ('define . _) . _)) . rest)
4021 (loop rest (append defs (parse-def beg))))
4022 (((and beg ('begin ('define-structure . _) . _))
4025 (loop rest (append defs (parse-def beg))))
4028 ('define-const-structure . _)
4033 (loop rest (append defs (parse-def beg))))
4034 ((_ . _) (make-body defs (smap parse-exp b)))
4037 "invalid body at ~a"
4046 (syntax-err exp "name ~a repeated" x)
4047 (no-repeats l exp)))))))
4048 (parse-exp expression))))
4050 (lambda (pat expression)
4053 (#f (make-ppred 'false-object?))
4054 (#t (make-ppred 'true-object?))
4055 (() (make-ppred 'null?))
4056 ((? number? c) (make-pconst c 'number?))
4057 ((? char? c) (make-pconst c 'char?))
4058 ((? string? c) (make-pconst c 'string?))
4059 (('quote x) (parse-quote x))
4061 ('else (make-pelse))
4062 ((? symbol? n) (make-pvar (parse-pname n)))
4066 "not patterns are not supported"))
4070 "or patterns are not supported"))
4074 "get! patterns are not supported"))
4078 "set! patterns are not supported"))
4080 (let* ((pats (smap parse-pat pats))
4081 (p (make-flat-pand pats))
4089 (when (< 1 (length (filter non-var? pats)))
4092 "~a has conflicting subpatterns"
4096 (('? (? symbol? pred) p)
4097 (parse-pat `(and (? ,pred) ,p)))
4098 (('? (? symbol? pred))
4102 "invalid use of keyword ~a"
4105 (('$ (? symbol? c) . args)
4106 (if (memq c '(? _ $))
4109 "invalid use of pattern keyword ~a"
4112 (symbol-append c '?)
4113 (smap parse-pat args))))
4115 (make-pobj 'box? (list (parse-pat (unbox cb)))))
4119 (list (parse-pat x) (parse-pat y))))
4123 (map parse-pat (vector->list v))))
4124 (m (syntax-err expression "invalid pattern at ~a" m))))
4127 (#f (make-pobj 'false-object? '()))
4128 (#t (make-pobj 'true-object? '()))
4129 (() (make-pobj 'null? '()))
4130 ((? number? c) (make-pconst c 'number?))
4131 ((? char? c) (make-pconst c 'char?))
4132 ((? string? c) (make-pconst c 'string?))
4133 ((? symbol? s) (make-pconst s 'symbol?))
4135 (make-pobj 'box? (list (parse-quote (unbox cb)))))
4139 (list (parse-quote x) (parse-quote y))))
4143 (map parse-quote (vector->list v))))
4144 (m (syntax-err expression "invalid pattern at ~a" m))))
4151 "invalid use of keyword ~a"
4153 ((memq s '(? _ else $ and or not set! get! ...))
4156 "invalid use of pattern keyword ~a"
4161 "invalid pattern variable at ~a"
4168 ((x . r) (let ((v (f x))) (cons v (smap f r))))
4169 (_ (syntax-err l "invalid list")))))
4172 (list (string->symbol "#primitive") p)))
4195 define-const-structure
4200 (and keep-match (eq? s 'match)))))
4201 (define make-flat-pand
4203 (let* ((l (foldr (lambda (p plist)
4205 (($ pand pats) (append pats plist))
4206 (_ (cons p plist))))
4217 (filter concrete? l)
4218 (filter (lambda (x) (not (concrete? x))) l))))
4219 (match sorted ((p) p) (_ (make-pand sorted))))))
4220 (define never-counter 0)
4221 (define reinit-macros!
4222 (lambda () (set! never-counter 0)))
4226 ((e (cdr cond-expr)))
4230 (set! never-counter (+ 1 never-counter))
4231 `(,(primitive 'should-never-reach)
4232 '(cond ,never-counter))))
4233 ((('else b1 . body)) `(begin ,b1 ,@body))
4235 (syntax-err cond-expr "invalid cond expression"))
4236 (((test '=> proc) . rest)
4239 (if ,g (,proc ,g) ,(loop rest)))))
4240 (((#t b1 . body)) `(begin ,b1 ,@body))
4241 (((test) . rest) `(or ,test ,(loop rest)))
4242 (((test . body) . rest)
4243 `(if ,test (begin ,@body) ,(loop rest)))
4244 (_ (syntax-err cond-expr "invalid cond expression"))))))
4245 (define scheme-cond-tf
4248 ((e (cdr cond-expr)))
4250 (() `(,(primitive 'void)))
4251 ((('else b1 . body)) `(begin ,b1 ,@body))
4253 (syntax-err cond-expr "invalid cond expression"))
4254 (((test '=> proc) . rest)
4257 (if ,g (,proc ,g) ,(loop rest)))))
4258 (((#t b1 . body)) `(begin ,b1 ,@body))
4259 (((test) . rest) `(or ,test ,(loop rest)))
4260 (((test . body) . rest)
4261 `(if ,test (begin ,@body) ,(loop rest)))
4262 (_ (syntax-err cond-expr "invalid cond expression"))))))
4266 ((e (cdr case-expr)))
4268 ((exp) `(begin ,exp (,(primitive 'void))))
4269 ((exp ('else b1 . body)) `(begin ,b1 ,@body))
4270 ((exp ('else . _) . _)
4271 (syntax-err case-expr "invalid case expression"))
4273 ((? list? test) b1 . body)
4276 `(if (,(primitive 'memv) ,exp ',test)
4278 ,(loop (cons exp rest))))
4279 (((? symbol? exp) (test b1 . body) . rest)
4280 `(if (,(primitive 'memv) ,exp '(,test))
4282 ,(loop (cons exp rest))))
4284 (if (not (symbol? exp))
4286 `(let ((,g ,exp)) ,(loop (cons g rest))))
4287 (syntax-err case-expr "invalid case expression")))
4288 (_ (syntax-err case-expr "invalid case expression"))))))
4289 (define conslimit 8)
4292 (letrec ((qloop (match-lambda
4294 `(,(primitive qbox) ,(qloop (unbox q))))
4295 ((? symbol? q) `',q)
4298 (if (< (length q) conslimit)
4299 `(,(primitive qcons)
4302 `(,(primitive qlist) ,@(map qloop q))))
4304 `(,(primitive qcons) ,(qloop x) ,(qloop y)))
4306 `(,(primitive qvector)
4307 ,@(map qloop (vector->list q))))
4314 "invalid quote expression at ~a"
4317 (('quote q) (qloop q))
4318 ((? vector? q) (qloop q))
4319 ((? box? q) (qloop q))))))
4320 (define quasiquote-tf
4324 (cond ((null? y) `(,(primitive 'list) ,x))
4326 (equal? (car y) (primitive 'list)))
4327 (cons (car y) (cons x (cdr y))))
4328 (else `(,(primitive 'cons) ,x ,y)))))
4329 (qloop (lambda (e n)
4332 (make-cons 'quasiquote (qloop `(,e) (+ 1 n))))
4336 (make-cons 'unquote (qloop `(,e) (- n 1)))))
4337 (('unquote-splicing e)
4342 (qloop `(,e) (- n 1)))))
4343 ((('unquote-splicing e) . y)
4348 `(,(primitive 'append) ,e ,(qloop y n)))
4351 `(,(primitive 'box) ,(qloop (unbox q) n)))
4354 '(quasiquote unquote unquote-splicing))
4357 "invalid use of ~a inside quasiquote"
4361 ((x . y) (make-cons (qloop x n) (qloop y n)))
4363 `(,(primitive 'vector)
4364 ,@(map (lambda (z) (qloop z n))
4372 "invalid quasiquote expression at ~a"
4374 (match exp (('quasiquote q) (qloop q 0))))))
4380 (((? list? vis) (e0 ? list? e1) ? list? c)
4381 (if (andmap (match-lambda ((_ _ . _) #t) (_ #f)) vis)
4382 (let* ((var (map car vis))
4383 (init (map cadr vis))
4384 (step (map cddr vis))
4385 (step (map (lambda (v s)
4391 "invalid do expression"))))
4394 (let ((doloop (gensym)))
4398 ,(map list var init)
4400 (begin ,@c (,doloop ,@step) (void))
4402 ((body0 ? list? body)
4404 ,(map list var init)
4406 (begin ,body0 ,@body)
4407 (begin ,@c (,doloop ,@step)))))
4410 "invalid do expression")))))
4411 (syntax-err do-expr "invalid do expression")))
4412 (_ (syntax-err do-expr "invalid do expression"))))))
4413 (define empty-env '())
4417 (#f (disaster 'lookup "no binding for ~a" x))
4421 (match (assq x env) (#f #f) ((_ . b) b))))
4424 (match (assq x env) (#f #f) (_ #t))))
4426 (lambda (env x v) (cons (cons x v) env)))
4429 (append (map2 cons xs vs) env)))
4431 (lambda (env newenv) (append newenv env)))
4432 (define populated #t)
4434 (define global-error #f)
4437 (define fullsharing #t)
4438 (define dump-depths #f)
4441 (c depth kind fsym pres args next))
4443 (v depth kind name vis split inst))
4444 (define-structure (ts type n-gen))
4445 (define-structure (k name order args))
4446 (define top (box 'top))
4447 (define bot (box 'bot))
4448 (define generic? (lambda (d) (< d 0)))
4455 (cons t (vector-ref types d)))
4457 (define generate-counter
4459 (let ((n 0)) (lambda () (set! n (+ 1 n)) n))))
4460 (define var-counter (generate-counter))
4461 (define make-raw-tvar
4462 (lambda (d k) (make-v d k var-counter #t #f #f)))
4464 (lambda (d k) (new-type (make-raw-tvar d k) d)))
4465 (define ord? (lambda (k) (eq? 'ord k)))
4466 (define abs? (lambda (k) (eq? 'abs k)))
4467 (define pre? (lambda (k) (eq? 'pre k)))
4468 (define ord-depth 2)
4469 (define depth ord-depth)
4470 (define types (make-vector 16 '()))
4471 (define reset-types!
4473 (set! depth ord-depth)
4474 (set! types (make-vector 16 '()))))
4477 (set! depth (+ depth 1))
4478 (when (< (vector-length types) (+ 1 depth))
4480 (let ((l (vector->list types)))
4482 (append l (map (lambda (_) '()) l))))))))
4485 (vector-set! types depth '())
4486 (set! depth (- depth 1))))
4487 (define v-ord (lambda () (make-tvar depth 'ord)))
4488 (define v-abs (lambda () (make-tvar depth 'abs)))
4489 (define v-pre (lambda () (make-tvar depth 'pre)))
4492 (lambda () (make-tvar (- depth 1) 'ord)))
4494 (lambda () (make-tvar ord-depth 'ord)))
4497 (($ box (and x ($ v d k _ vis _ _)))
4499 (number? (v-name x))
4500 (set-v-name! x ((v-name x))))
4509 ('abs (if vis "A" "a"))
4510 ('pre (if vis "P" "p")))
4512 (if dump-depths (sprintf ".~a" d) ""))))))
4513 (define make-tvar-like
4515 (($ box ($ v d k _ _ _ _)) (make-tvar d k))))
4520 (let ((v (ind* u))) (set-box! t v) v))
4524 ((abs def inexhaust once _)
4525 (cond (((if once check-abs1? check-abs?) abs)
4526 (if (and def (definite? def)) 'def #t))
4527 (inexhaust 'inexhaust)
4529 (define type-check1?
4531 ((abs def inexhaust _ _)
4532 (cond ((check-abs1? abs)
4533 (if (and def (definite? def)) 'def #t))
4534 (inexhaust 'inexhaust)
4541 (($ box ($ v _ _ _ _ _ inst))
4545 (set! seen (cons t seen))
4546 (ormap (match-lambda ((t . _) (labs? t)))
4548 (($ box ($ c _ _ _ p _ n))
4549 (or (labs? p) (labs? n)))
4550 (($ box (? symbol?)) #t)
4551 (($ box i) (labs? i))))))
4552 (ormap labs? vlist))))
4559 (($ box ($ c _ _ _ p _ n))
4560 (or (labs1? p) (labs1? n)))
4561 (($ box (? symbol?)) #t)
4562 (($ box i) (labs1? i))))))
4563 (ormap labs1? vlist))))
4564 (define check-sources
4567 (lsrcs (lambda (t source)
4569 (($ box ($ v _ k _ _ _ inst))
4570 (union (if (and inst (not (memq t seen)))
4572 (set! seen (cons t seen))
4576 ((t . s) (lsrcs t s)))
4579 (($ box ($ c _ _ _ p _ n))
4580 (union (lsrcs p source) (lsrcs n source)))
4581 (($ box (? symbol?))
4582 (if source (set source) empty-set))
4583 (($ box i) (lsrcs i source))))))
4585 (((abs _ _ _ _) info))
4590 (map (lambda (t) (lsrcs t #f)) abs)))))))
4591 (define check-local-sources
4592 (match-lambda ((_ _ _ _ component) component)))
4593 (define mk-definite-prim
4595 (($ box ($ c _ _ x p a n))
4596 (if (eq? (k-name x) '?->)
4601 (($ box ($ c _ _ x p a n))
4605 (set! seen (cons t seen))
4607 ('noarg (cons p (lprim n)))
4609 (let ((args (recur argloop
4639 (cons (list p args (lprim (cadr a)))
4641 (($ box ($ v _ k _ _ _ _))
4642 (if (ord? k) (list t) '()))
4643 (($ box (? symbol?)) '())
4644 (($ box i) (lprim i)))))
4645 (mk-definite-prim n)))
4646 (($ box (? v?)) '())
4647 (($ box (? symbol?)) '())
4648 (($ box i) (mk-definite-prim i))))
4649 (define mk-definite-app
4651 (($ box ($ c _ _ _ p _ _)) (list p))))
4652 (define mk-definite-lam
4654 (($ box ($ c _ _ x p a n))
4655 (if (eq? (k-name x) '?->)
4660 (($ box ($ c _ _ x p a n))
4664 (set! seen (cons t seen))
4666 ('noarg (cons p (llam n)))
4668 (let ((args (list top)))
4669 (cons (list p args (llam (cadr a)))
4671 (($ box ($ v _ k _ _ _ _))
4672 (if (ord? k) (list t) '()))
4673 (($ box (? symbol?)) '())
4674 (($ box i) (llam i)))))
4675 (mk-definite-lam n)))
4676 (($ box (? v?)) '())
4677 (($ box (? symbol?)) '())
4678 (($ box i) (mk-definite-lam i))))
4681 (letrec ((non-empty?
4687 (($ box ($ c _ _ _ p _ n))
4688 (or (ldef p) (ldef n)))
4689 (($ box ($ v d k _ _ _ inst))
4690 (if (or global-error (abs? k))
4695 (set! seen (cons t seen))
4696 (ormap (match-lambda
4702 (($ box i) (ldef i)))))))
4704 (ormap (match-lambda
4705 ((? box? t) (non-empty? t))
4708 (ormap non-empty? arg)
4711 (not (ok def-info)))))
4713 (lambda (t-list) (close-type t-list #f)))
4715 (lambda (t) (car (close-type (list t) #t))))
4718 (cond ((= from to) (f from))
4720 (begin (f from) (for (+ from 1) to f)))
4723 (lambda (t-list all?)
4724 (let* ((sorted (make-vector (+ depth 1) '()))
4727 (($ box ($ c d _ _ _ _ _))
4731 (cons t (vector-ref sorted d))))
4732 (($ box ($ v d _ _ _ _ _))
4736 (cons t (vector-ref sorted d))))
4740 (letrec ((pr (match-lambda
4741 (($ box (and x ($ v d _ _ _ _ _)))
4742 (when (< down d) (set-v-depth! x down)))
4743 (($ box (and x ($ c d _ _ p a n)))
4745 (set-c-depth! x down)
4749 (($ box (? symbol?)) #f)
4750 (z (pr (ind* z))))))
4752 (($ box (and x ($ c d _ _ p a n)))
4753 (when (<= down d) (pr p) (for-each pr a) (pr n)))
4757 (let ((pk (lambda (kind)
4760 (($ box (and x ($ v _ k _ _ _ _)))
4761 (when (kind< kind k) (set-v-kind! x kind)))
4762 (($ box (and x ($ c _ k _ p a n)))
4763 (when (kind< kind k)
4764 (set-c-kind! x kind)
4766 (unless populated (for-each pr a))
4768 (($ box (? symbol?)) #f)
4769 (z (pr (ind* z))))))))
4771 (($ box (and x ($ c _ k _ p a n)))
4772 (when (not (ord? k))
4773 (let ((prop (pk k)))
4775 (unless populated (for-each prop a))
4778 (might-be-generalized?
4780 (($ box ($ v d k _ _ _ _))
4781 (and (<= depth d) (or populated (ord? k) all?)))
4782 (($ box ($ c d k _ _ _ _))
4783 (and (<= depth d) (or populated (ord? k) all?)))
4784 (($ box (? symbol?)) #f)))
4788 (($ box ($ v d _ _ _ _ _)) d)
4789 (($ box ($ c d _ _ _ _ _)) d)))
4792 (let* ((n (vector-length v))
4793 (v2 (make-vector (* n 2) '())))
4797 (vector-set! v2 i (vector-ref v i))
4800 (parents (make-vector 64 '()))
4804 (let ((d (depth-of t)))
4806 (vector-ref parents (- (- d depth) 1))
4811 (($ box (and x ($ v d _ _ _ _ _)))
4813 (set! parent-index (+ 1 parent-index))
4814 (set-v-depth! x (+ depth parent-index))
4815 (when (< (vector-length parents) parent-index)
4816 (set! parents (vector-grow parents)))
4817 (set! d (+ depth parent-index)))
4822 (vector-ref parents (- (- d depth) 1)))))
4823 (($ box (and x ($ c d _ _ _ _ _)))
4825 (set! parent-index (+ 1 parent-index))
4826 (set-c-depth! x (+ depth parent-index))
4827 (when (< (vector-length parents) parent-index)
4828 (set! parents (vector-grow parents)))
4829 (set! d (+ depth parent-index)))
4834 (vector-ref parents (- (- d depth) 1))))))))
4840 (cond ((not (might-be-generalized? t)) #f)
4841 ((null? (parents-of t))
4842 (xtnd-parents! t parent)
4843 (set! needs-cleanup (cons t needs-cleanup))
4846 (set! leaves (cons t leaves)))
4847 (($ box ($ c _ _ _ p a n))
4848 (let ((rev (lambda (q) (revtype t q))))
4852 ((not (memq parent (parents-of t)))
4853 (xtnd-parents! t parent))
4859 (when (might-be-generalized? t)
4860 (set! generic-index (- generic-index 1))
4861 (let ((parents (parents-of t)))
4863 (($ box (and x ($ v _ k _ _ _ _)))
4864 (set-v-depth! x generic-index)
4865 (when (and populated
4870 (set-v-inst! x '())))
4872 (set-c-depth! x generic-index)))
4873 (for-each gen parents)))))))
4876 (($ box (and x ($ v d _ _ _ _ _)))
4877 (unless (< d 0) (set-v-depth! x (- depth 1))))
4878 (($ box (and x ($ c d _ _ _ _ _)))
4879 (unless (< d 0) (set-c-depth! x (- depth 1))))))
4883 (when (might-be-generalized? t)
4884 (set! generic-index (- generic-index 1))
4886 (($ box (and x ($ v _ k _ _ _ _)))
4887 (set-v-depth! x generic-index)
4888 (when (and populated
4893 (set-v-inst! x '())))
4894 (($ box (and x ($ c _ _ _ p a n)))
4895 (set-c-depth! x generic-index)
4900 (let ((d (depth-of t)))
4905 (cons t (vector-ref types d))))))))
4906 (for-each sort (vector-ref types depth))
4910 (for-each (prop-d i) (vector-ref sorted i))))
4911 (for-each prop-k (vector-ref types depth))
4912 (vector-set! types depth '())
4915 (for-each (lambda (t) (revtype t t)) t-list)
4916 (for-each gen leaves)
4917 (for-each cleanup needs-cleanup))
4918 (for-each gen2 t-list))
4921 (lambda (i) (for-each upd (vector-ref sorted i))))
4925 ((n-gen (- generic-index))
4927 (if (and pseudo flags (not all?))
4928 (pseudo t-list n-gen)
4929 (list t-list n-gen))))
4930 (visible t-list n-gen)
4931 (map (lambda (t) (make-ts t n-gen)) t-list))))))
4932 (define visible-time 0)
4934 (lambda (t-list n-gen)
4935 (let* ((before (cpu-time))
4936 (valences (make-vector n-gen '()))
4937 (namer (generate-counter))
4941 (($ box ($ c d _ x p a n))
4942 (when (and (generic? d)
4948 (let ((u (union (vector-ref
4952 (vector-set! valences (- (- d) 1) u))
4956 (lvis (car a) (not pos) #f)
4957 (lvis (cadr a) pos #f))
4958 ('record (lvis (car a) pos #t))
4960 (lambda (x) (lvis x pos #f))
4963 (($ box (and x ($ v d k _ _ _ _)))
4964 (when (and (generic? d)
4970 (let ((u (union (vector-ref
4974 (vector-set! valences (- (- d) 1) u)
4975 (set-v-name! x namer)
4977 ((= 2 (cardinality u))
4980 ((eq? pos rcd) (set-v-vis! x #t))
4981 (else (set-v-vis! x #f))))))
4982 (($ box (? symbol?)) #f)
4983 (($ box i) (lvis i pos rcd)))))))
4984 (for-each (lambda (t) (lvis t #t #f)) t-list)
4986 (+ visible-time (- (cpu-time) before))))))
4989 (($ box ($ v _ k _ vis _ _))
4990 (or (pre? k) (and vis (not (abs? k)))))
4993 (($ box i) (visible? i))))
4999 (seen (make-vector n-gen #f))
5003 (($ box (and y ($ v d k _ _ _ inst)))
5004 (cond ((not (generic? d)) t)
5005 ((vector-ref seen (- (- d) 1)))
5007 (let ((u (make-tvar depth k)))
5008 (vector-set! seen (- (- d) 1) u)
5012 (cons (cons u syntax)
5014 (when (or (abs? k) (pre? k))
5015 (set! absv (cons u absv)))
5017 (($ box ($ c d _ x p a n))
5018 (cond ((not (generic? d)) t)
5019 ((vector-ref seen (- (- d) 1)))
5024 (vector-set! seen (- (- d) 1) u)
5031 (if flags (linst p) top)
5035 (($ box (? symbol?)) t)
5036 (($ box i) (linst i))))))
5038 (define pseudo-subtype
5039 (lambda (t-list n-gen)
5040 (let* ((valences (make-vector n-gen '()))
5042 (lambda (d) (vector-ref valences (- (- d) 1))))
5045 (vector-set! valences (- (- d) 1) v)))
5047 (lambda (t pos mutable)
5049 (($ box ($ v d _ _ _ _ _))
5052 (set-valence d (set #t #f)))
5058 (union (valence-of d)
5061 (($ box ($ c d _ x p a n))
5063 (cond ((= 2 (cardinality (valence-of d)))
5066 (set-valence d (set #t #f))
5069 (find t pos mutable))
5072 (find n pos mutable))
5078 (union (valence-of d)
5080 (if (eq? '?-> (k-name x))
5085 (find (cadr a) pos mutable))
5088 (find t pos (or m mutable)))
5091 (find n pos mutable))
5093 (($ box (? symbol?)) #f)
5094 (($ box i) (find i pos mutable))))))
5095 (seen (make-vector n-gen #f))
5098 (set! n-gen (+ 1 n-gen))
5099 (box (make-raw-tvar (- n-gen) 'ord))))
5103 (($ box ($ v d k _ _ _ _))
5105 (or (vector-ref seen (- (- d) 1))
5106 (let ((u (if (and (abs? k)
5112 (vector-set! seen (- (- d) 1) u)
5115 (($ box ($ c d k x p a n))
5117 (or (vector-ref seen (- (- d) 1))
5118 (let* ((u (box '**fix**))
5123 (new-p (if (and (eq? (ind* p) top)
5129 (new-a (map copy a))
5133 (make-c d 'ord x new-p new-a new-n))
5136 (($ box (? symbol?)) t)
5137 (($ box i) (copy i))))))
5139 (map (lambda (t) (find t #t #f) (copy t)) t-list)))
5140 (list t-list n-gen))))
5141 (set! pseudo pseudo-subtype)
5143 (letrec ((uni (lambda (u v)
5147 ((($ box (and us ($ c ud uk ux up ua un)))
5150 (and vs ($ c vd vk vx vp va vn)))
5156 (when (kind< vk uk) (set-c-kind! us vk)))
5159 (when (kind< uk vk) (set-c-kind! vs uk))))
5161 (for-each2 uni ua va)
5163 (let* ((next (tvar))
5164 (k (if (kind< uk vk) uk vk)))
5167 (when (< vd ud) (set-c-depth! us vd))
5168 (when (kind< vk uk) (set-c-kind! us vk))
5171 (when (< ud vd) (set-c-depth! vs ud))
5172 (when (kind< uk vk) (set-c-kind! vs uk))
5175 (make-c depth k ux up ua next)
5180 (make-c depth k vx vp va next)
5182 ((($ box (and x ($ v ud uk _ _ _ _)))
5185 ($ v vd vk _ _ _ _))
5186 (set-v-depth! x (min ud vd))
5187 (set-v-kind! x (if (kind< uk vk) uk vk))
5189 ((($ box ($ v ud uk _ _ _ _))
5192 (and x ($ c vd vk _ _ _ _)))
5193 (when (< ud vd) (set-c-depth! x ud))
5194 (when (kind< uk vk) (set-c-kind! x uk))
5196 ((($ box (and x ($ c ud uk _ _ _ _)))
5199 ($ v vd vk _ _ _ _))
5200 (when (< vd ud) (set-c-depth! x vd))
5201 (when (kind< vk uk) (set-c-kind! x vk))
5203 ((($ box ($ v _ _ _ _ _ _)) $ box (? symbol?))
5205 ((($ box (? symbol?)) $ box ($ v _ _ _ _ _ _))
5207 ((($ box 'bot) $ box ($ c _ _ _ p _ n))
5211 ((($ box ($ c _ _ _ p _ n)) $ box 'bot)
5215 (_ (uni (ind* u) (ind* v))))))))
5218 (lambda (k1 k2) (and (ord? k2) (not (ord? k1)))))
5220 (lambda (flag+ flag- tail+- absent- pos env type)
5221 (letrec ((absent+ v-ord)
5227 (cond ((not flags) top)
5233 (not (bound? env v))
5252 (raise 'type "invalid type syntax at ~a" t))
5253 (when (assq a tvars)
5254 (raise 'type "~a is defined more than once" a))
5255 (let* ((fix (new-type '**fix** depth))
5256 (_ (set! tvars (cons (list a fix '()) tvars)))
5257 (t (parse-type t pos)))
5260 "recursive type is not contractive"))
5263 (('rec (? list? bind) t2)
5269 (raise 'type "invalid type syntax at ~a" t))
5270 (when (assq a tvars)
5272 "~a is defined more than once"
5275 (cons (list a (new-type '**fix** depth) '())
5277 (_ (raise 'type "invalid type syntax at ~a" t)))
5282 (match (assq a tvars)
5284 (let ((t (parse-type t '?)))
5287 "type is not contractive"))
5288 (set-box! fix t))))))
5290 (parse-type t2 pos))
5291 ('bool (parse-type '(+ false true) pos))
5309 (parse-type `(mu ,u (+ nil (cons ,t ,u))) pos)))
5312 (parse-type `(mu ,u (+ noarg (arg ,t ,u))) pos)))
5313 (('+ ? list? union) (parse-union union pos))
5314 (t (parse-union (list t) pos)))))
5321 (lambda (x y) (k< (c-fsym x) (c-fsym y))))))
5324 (new-type c depth))))
5332 (let ((v (absent-)))
5333 (set! absv (cons v absv))
5336 (((? box? t)) (foldr link t (sort-cs cs)))
5337 (('_) (foldr link (tail+-) (sort-cs cs)))
5340 (unless (typevar? a) (fail))
5341 (let* ((cs (sort-cs cs))
5342 (ks (map c-fsym cs)))
5344 (match (assq a tvars)
5349 "variable ~a is not tidy"
5360 (loop rest (cons (parse-k k pos) cs))))))))
5363 (cond ((and (list? k)
5364 (let ((n (length k)))
5365 (and (<= 2 n) (eq? '-> (list-ref k (- n 2))))))
5366 (let* ((rk (reverse k))
5367 (arg (reverse (cddr rk)))
5375 `(mu ,u (+ noarg (arg ,x ,u)))))
5377 `(+ noarg (arg ,x noarg)))
5378 ((x . y) `(arg ,x ,(mkargs y)))
5380 "invalid type syntax")))))
5386 (let ((a (parse-type (mkargs arg) (flip pos)))
5387 (r (parse-type res pos)))
5398 (let ((a (parse-type arg (flip pos)))
5399 (r (parse-type res pos)))
5402 (('record ? list? fields)
5406 (lookup env 'record)
5411 (() (if pos bot (v-ord)))
5412 ((((? symbol? f) ftype)
5439 (let ((v (absent-)))
5440 (set! absv (cons v absv))
5442 (map (lambda (x) (tail+-)) (k-args k))
5447 (raise 'type "invalid type syntax at ~a" k))
5448 (let ((k (lookup env c)))
5455 (let ((v (absent-)))
5456 (set! absv (cons v absv))
5458 (map (lambda (x) (tail+-)) (k-args k))
5460 (('*tidy c (? symbol? f))
5463 (raise 'type "invalid type syntax at ~a" k))
5464 (let ((k (lookup env c)))
5469 (match (assq f fvars)
5474 (cons (cons f v) fvars))
5476 (map (lambda (x) (parse-type '(+) pos))
5479 (((? k? k) ? list? arg)
5481 (= (length arg) (length (k-args k)))
5483 "~a requires ~a arguments"
5485 (length (k-args k))))
5491 (smap (lambda (x) (parse-type x pos)) arg)
5496 (raise 'type "invalid type syntax at ~a" k))
5497 (let ((k (lookup env c)))
5499 (= (length arg) (length (k-args k)))
5501 "~a requires ~a arguments"
5503 (length (k-args k))))
5509 (smap (lambda (x) (parse-type x pos)) arg)
5514 "invalid type syntax at ~a"
5516 (let ((k (lookup env c)))
5518 (= 0 (length (k-args k)))
5520 "~a requires ~a arguments"
5522 (length (k-args k))))
5530 (flip (match-lambda ('? '?) (#t #f) (#f #t))))
5531 (let ((t (parse-type type pos))) (list t absv)))))
5532 (define v-top (lambda () top))
5535 (car (r+- v-top v-ord v-ord v-abs #t env t))))
5538 (car (r+- v-top v-ord v-ord v-abs #f env t))))
5541 (car (r+- v-top v-ord v-ord v-ord #t env t))))
5544 (r+- v-top v-ord v-ord v-abs #t env t)))
5547 (r+- v-top v-ord v-ord v-abs #f env t)))
5548 (define r (lambda (t) (r+ initial-type-env t)))
5552 '(pretty-print `(fixing ,(ptype t)))
5554 (list t (collect-abs t))))
5561 (($ box ($ v _ k _ _ _ _))
5562 (if (abs? k) (set t) empty-set))
5563 (($ box ($ c _ _ _ p a n))
5567 (set! seen (cons t seen))
5569 (union (loop p) (loop n))
5571 (($ box (? symbol?)) empty-set)
5572 (($ box i) (loop i)))))))
5573 (define fix-pat-abs!
5579 (($ box (and x ($ v d _ _ _ _ _)))
5580 (when (= d depth) (set-v-kind! x 'abs)))
5581 (($ box (and c ($ c _ _ _ p a n)))
5584 (set! seen (cons t seen))
5586 (when (and matchst flags (eq? (ind* p) top))
5587 (set-c-pres! c (v-ord)))
5590 (($ box (? symbol?)) t)
5591 (($ box i) (loop i)))))))
5592 (define pat-var-bind
5598 (($ box ($ v d _ _ _ _ _))
5601 (match (assq t seen)
5604 (let* ((new (v-ord)))
5605 (set! seen (cons (cons t new) seen))
5607 (($ box ($ c d k x p a n))
5608 (match (assq t seen)
5611 (let* ((fix (new-type '**fix** depth))
5613 (_ (set! seen (cons (cons t fixbox) seen)))
5614 (new-p (if flags (loop p) top))
5615 (new-a (map2 (lambda (mutable a)
5616 (if mutable a (loop a)))
5620 (if (and (eq? new-p p)
5622 (andmap eq? new-a a))
5623 (begin (set-box! fixbox t) t)
5627 (make-c d k x new-p new-a new-n))
5629 (($ box (? symbol?)) t)
5630 (($ box i) (loop i)))))))
5634 (match (assq x fields)
5636 (let ((k (make-k x (+ 1 (length fields)) '(#f))))
5637 (set! fields (cons (cons x k) fields))
5641 (lambda (x y) (< (k-order x) (k-order y))))
5642 (define k-counter 0)
5644 (lambda (x args covers fail-thunk)
5657 (fail-thunk "invalid type constructor ~a" x))
5658 (set! k-counter (+ 1 k-counter))
5661 (symbol-append x "." (- k-counter 100))
5665 (define initial-type-env '())
5669 (set! var-counter (generate-counter))
5670 (set! initial-type-env
5671 (foldl (lambda (l env)
5679 (lambda x (apply disaster 'init x)))))
5682 (set! k-counter 100)
5684 (define reinit-types!
5686 (set! var-counter (generate-counter))
5687 (set! k-counter 100)
5689 (set-cons-mutability! #t)
5692 (lambda (tag mutability)
5693 (set! initial-type-env
5699 (+ 1 (length initial-type-env))
5701 (define initial-type-info
5723 (define cons-is-mutable #f)
5724 (define set-cons-mutability!
5726 (set! cons-is-mutable m)
5728 (lookup initial-type-env 'cons)
5737 (match (assq t seen)
5738 (#f (set! seen (cons (cons t label) seen)) #t)
5739 ((_ . l2) (equal? label l2))))
5740 (($ box ($ c _ _ x _ a n))
5741 (match (assq t seen)
5742 ((_ . l2) (equal? label l2))
5744 (set! seen (cons (cons t label) seen))
5745 (and (loop n (sort-list (cons x label) k<))
5746 (andmap (lambda (t) (loop t '())) a)))))
5747 (($ box (? symbol?)) #t)
5748 (($ box i) (loop i label)))))))
5752 (tidy-print t print-union assemble-union #f))
5753 (t (tidy-print t print-union assemble-union #f))))
5768 (lambda (t print assemble top)
5769 (let* ((share (shared-unions t top))
5776 (symbol-append "Y" (+ 1 n))))
5778 (body (print t (print-binding bindings)))
5782 ((_ _ ($ box #f) _) #f)
5783 ((_ ($ box t) ($ box x) _) (list x t)))
5785 (assemble let-bindings body))))
5786 (define print-binding
5788 (lambda (ty share-wrapper var-wrapper render)
5789 (match (assq ty bindings)
5791 ((_ box-tprint box-name nprint)
5793 (or (unbox box-name)
5795 (set-box! box-name nprint)
5796 (set-box! box-tprint (share-wrapper (render)))
5798 (define shared-unions
5805 (($ box ($ c _ _ _ _ a n))
5806 (match (and top (assq t seen))
5808 (set! seen (cons (cons t (box 1)) seen))
5809 (for-each (lambda (x) (loop x #t)) a)
5811 ((_ . b) (set-box! b (+ 1 (unbox b))))))
5812 (($ box (? symbol?)) #f)
5813 (($ box i) (loop i top))))
5816 (match-lambda ((_ $ box 1) #f) ((t . _) t))
5818 (define print-raw-union
5819 (lambda (t print-share)
5823 (($ box ($ v _ _ _ _ split _))
5824 (if (and share split)
5825 (string->symbol (sprintf "~a#" (pvar t)))
5827 (($ box ($ c d k x p a n))
5833 (let* ((name (if (abs? k)
5834 (symbol-append '~ (k-name x))
5836 (name (if dump-depths
5837 (symbol-append d '! name)
5839 (pr-x `(,name ,@(maplr loop (cons p a)))))
5840 (cons pr-x (loop n))))))
5843 (($ box i) (loop i))))))
5844 (define assemble-raw-union
5845 (lambda (bindings body)
5846 (if (null? bindings) body `(rec ,bindings ,body))))
5848 (lambda (t print-share)
5850 ((t t) (tailvis (visible? (tailvar t))))
5853 (if (visible? t) (list (pvar t)) '()))
5854 (($ box ($ c _ _ x p a n))
5874 (kname (if split-flag
5881 (cons (cond ((null? a) kname)
5882 ((eq? '?-> (k-name x))
5883 (let ((arg (add-+ (loop (car a)
5887 (res (add-+ (loop (cadr a)
5902 ((eq? 'record (k-name x))
5904 ,@(loop (car a) #f)))
5907 ,@(maplr (lambda (x)
5914 ((not tailvis) (loop n tailvis))
5916 (cons `(not ,(k-name x))
5917 (loop n tailvis)))))))
5919 (($ box i) (loop i tailvis)))))))
5920 (define assemble-union
5921 (lambda (bindings body)
5923 (map clean-binding bindings)
5934 (($ box ($ c _ _ _ _ _ n)) (tailvar n))
5936 (($ box i) (tailvar i)))))
5937 (define decode-arrow
5938 (lambda (kname thunk-> arg res)
5939 (let ((args (recur loop
5943 (('arg a b) `(,a ,@(loop b)))
5944 (('+ ('arg a b) 'noarg . _)
5945 `((&optional ,a) ,@(loop b)))
5946 (('+ 'noarg ('arg a b) . _)
5947 `((&optional ,a) ,@(loop b)))
5949 (if (rectypevar? z) `(,z) `((&rest ,z))))
5950 (('+ 'noarg z) (loop z))
5952 (loop `(+ (arg ,a ,b) noarg ,z)))))))
5953 `(,@args ,(thunk->) ,res))))
5956 (memq (string-ref (symbol->string s) 0) '(#\Y))))
5959 (memq (string-ref (symbol->string s) 0)
5961 (define clean-binding
5964 ((u ('+ 'nil ('cons a v)))
5965 (if (and (equal? u v) (not (memq* u a)))
5968 ((u ('+ ('cons a v) 'nil))
5969 (if (and (equal? u v) (not (memq* u a)))
5972 ((u ('+ 'nil ('cons a v) (? symbol? z)))
5973 (if (and (equal? u v) (not (memq* u a)) (typevar? z))
5974 (list u `(list* ,a ,z))
5976 ((u ('+ ('cons a v) 'nil (? symbol? z)))
5977 (if (and (equal? u v) (not (memq* u a)) (typevar? z))
5978 (list u `(list* ,a ,z))
5980 ((u ('+ 'noarg ('arg a v)))
5981 (if (and (equal? u v) (not (memq* u a)))
5982 (list u `(&list ,a))
5984 ((u ('+ ('arg a v) 'noarg))
5985 (if (and (equal? u v) (not (memq* u a)))
5986 (list u `(&list ,a))
5994 ((x . y) (or (loop x) (loop y)))
5999 (('list elem) (subst-list elem old t))
6000 (_ (subst* new old t)))))
6002 (lambda (elem old t)
6004 ((? symbol?) (if (eq? old t) `(list ,elem) t))
6005 (('+ 'nil ('cons a (? symbol? b)))
6006 (if (and (eq? b old) (equal? elem a))
6008 `(+ nil (cons ,(subst-list elem old a) ,b))))
6009 (('+ ('cons a (? symbol? b)) 'nil)
6010 (if (and (eq? b old) (equal? elem a))
6012 `(+ nil (cons ,(subst-list elem old a) ,b))))
6014 (cons (subst-list elem old a)
6015 (subst-list elem old b)))
6019 (cond ((eq? old t) new)
6021 (cons (subst* new old (car t))
6022 (subst* new old (cdr t))))
6024 (define subst-small-type
6025 (lambda (bindings body)
6027 ((bindings bindings) (newb '()) (body body))
6032 ((name type) (not (equal? name type))))
6036 `(rec ,(reverse newb) ,body))))
6037 (((and b (name type)) . rest)
6038 (if (and (not (memq* name type)) (small-type? type))
6039 (loop (subst-type type name rest)
6040 (subst-type type name newb)
6041 (subst-type type name body))
6042 (loop rest (cons b newb) body)))))))
6052 ((x . y) (+ (loop x) (loop y)))
6056 (string->symbol (string-append "# " s))))
6057 (define qcons (qop "cons"))
6058 (define qbox (qop "box"))
6059 (define qlist (qop "list"))
6060 (define qvector (qop "vector"))
6061 (define initial-info
6063 (eqv? (a a -> bool))
6065 (equal? (a a -> bool))
6066 (cons (a b -> (cons a b)) (ic))
6067 (car ((cons a b) -> a) (s (x . _)))
6068 (cdr ((cons b a) -> a) (s (_ . x)))
6069 (caar ((cons (cons a b) c) -> a)
6071 (cadr ((cons c (cons a b)) -> a) (s (_ x . _)))
6072 (cdar ((cons (cons b a) c) -> a)
6074 (cddr ((cons c (cons b a)) -> a) (s (_ _ . x)))
6075 (caaar ((cons (cons (cons a b) c) d) -> a)
6076 (s (((x . _) . _) . _)))
6077 (caadr ((cons d (cons (cons a b) c)) -> a)
6078 (s (_ (x . _) . _)))
6079 (cadar ((cons (cons c (cons a b)) d) -> a)
6080 (s ((_ x . _) . _)))
6081 (caddr ((cons d (cons c (cons a b))) -> a)
6083 (cdaar ((cons (cons (cons b a) c) d) -> a)
6084 (s (((_ . x) . _) . _)))
6085 (cdadr ((cons d (cons (cons b a) c)) -> a)
6086 (s (_ (_ . x) . _)))
6087 (cddar ((cons (cons c (cons b a)) d) -> a)
6088 (s ((_ _ . x) . _)))
6089 (cdddr ((cons d (cons c (cons b a))) -> a)
6092 ((cons (cons (cons (cons a b) c) d) e) -> a)
6093 (s ((((x . _) . _) . _) . _)))
6095 ((cons e (cons (cons (cons a b) c) d)) -> a)
6096 (s (_ ((x . _) . _) . _)))
6098 ((cons (cons d (cons (cons a b) c)) e) -> a)
6099 (s ((_ (x . _) . _) . _)))
6101 ((cons e (cons d (cons (cons a b) c))) -> a)
6102 (s (_ _ (x . _) . _)))
6104 ((cons (cons (cons c (cons a b)) d) e) -> a)
6105 (s (((_ x . _) . _) . _)))
6107 ((cons e (cons (cons c (cons a b)) d)) -> a)
6108 (s (_ (_ x . _) . _)))
6110 ((cons (cons d (cons c (cons a b))) e) -> a)
6111 (s ((_ _ x . _) . _)))
6113 ((cons e (cons d (cons c (cons a b)))) -> a)
6116 ((cons (cons (cons (cons b a) c) d) e) -> a)
6117 (s ((((_ . x) . _) . _) . _)))
6119 ((cons e (cons (cons (cons b a) c) d)) -> a)
6120 (s (_ ((_ . x) . _) . _)))
6122 ((cons (cons d (cons (cons b a) c)) e) -> a)
6123 (s ((_ (_ . x) . _) . _)))
6125 ((cons e (cons d (cons (cons b a) c))) -> a)
6126 (s (_ _ (_ . x) . _)))
6128 ((cons (cons (cons c (cons b a)) d) e) -> a)
6129 (s (((_ _ . x) . _) . _)))
6131 ((cons e (cons (cons c (cons b a)) d)) -> a)
6132 (s (_ (_ _ . x) . _)))
6134 ((cons (cons d (cons c (cons b a))) e) -> a)
6135 (s ((_ _ _ . x) . _)))
6137 ((cons e (cons d (cons c (cons b a)))) -> a)
6139 (set-car! ((cons a b) a -> void))
6140 (set-cdr! ((cons a b) b -> void))
6141 (list ((&list a) -> (list a)) (ic))
6142 (length ((list a) -> num))
6143 (append ((&list (list a)) -> (list a)) (ic) (d))
6144 (reverse ((list a) -> (list a)) (ic))
6145 (list-tail ((list a) num -> (list a)) (c))
6146 (list-ref ((list a) num -> a) (c))
6147 (memq (a (list a) -> (+ false (cons a (list a)))))
6148 (memv (a (list a) -> (+ false (cons a (list a)))))
6150 (a (list a) -> (+ false (cons a (list a)))))
6151 (assq (a (list (cons a c)) -> (+ false (cons a c))))
6152 (assv (a (list (cons a c)) -> (+ false (cons a c))))
6153 (assoc (a (list (cons a c)) -> (+ false (cons a c))))
6154 (symbol->string (sym -> str))
6155 (string->symbol (str -> sym))
6156 (complex? (a -> bool))
6158 (rational? (a -> bool))
6159 (integer? (a -> bool))
6160 (exact? (num -> bool))
6161 (inexact? (num -> bool))
6162 (= (num num (&list num) -> bool))
6163 (< (num num (&list num) -> bool))
6164 (> (num num (&list num) -> bool))
6165 (<= (num num (&list num) -> bool))
6166 (>= (num num (&list num) -> bool))
6167 (zero? (num -> bool))
6168 (positive? (num -> bool))
6169 (negative? (num -> bool))
6170 (odd? (num -> bool))
6171 (even? (num -> bool))
6172 (max (num (&list num) -> num))
6173 (min (num (&list num) -> num))
6174 (+ ((&list num) -> num))
6175 (* ((&list num) -> num))
6176 (- (num (&list num) -> num))
6177 (/ (num (&list num) -> num))
6179 (quotient (num num -> num))
6180 (remainder (num num -> num))
6181 (modulo (num num -> num))
6182 (gcd ((&list num) -> num))
6183 (lcm ((&list num) -> num))
6184 (numerator (num -> num))
6185 (denominator (num -> num))
6186 (floor (num -> num))
6187 (ceiling (num -> num))
6188 (truncate (num -> num))
6189 (round (num -> num))
6190 (rationalize (num num -> num))
6198 (atan (num (&optional num) -> num))
6200 (expt (num num -> num))
6201 (make-rectangular (num num -> num))
6202 (make-polar (num num -> num))
6203 (real-part (num -> num))
6204 (imag-part (num -> num))
6205 (magnitude (num -> num))
6206 (angle (num -> num))
6207 (exact->inexact (num -> num))
6208 (inexact->exact (num -> num))
6209 (number->string (num (&optional num) -> str))
6210 (string->number (str (&optional num) -> num))
6211 (char=? (char char -> bool))
6212 (char<? (char char -> bool))
6213 (char>? (char char -> bool))
6214 (char<=? (char char -> bool))
6215 (char>=? (char char -> bool))
6216 (char-ci=? (char char -> bool))
6217 (char-ci<? (char char -> bool))
6218 (char-ci>? (char char -> bool))
6219 (char-ci<=? (char char -> bool))
6220 (char-ci>=? (char char -> bool))
6221 (char-alphabetic? (char -> bool))
6222 (char-numeric? (char -> bool))
6223 (char-whitespace? (char -> bool))
6224 (char-upper-case? (char -> bool))
6225 (char-lower-case? (char -> bool))
6226 (char->integer (char -> num))
6227 (integer->char (num -> char))
6228 (char-upcase (char -> char))
6229 (char-downcase (char -> char))
6230 (make-string (num (&optional char) -> str))
6231 (string ((&list char) -> str))
6232 (string-length (str -> num))
6233 (string-ref (str num -> char))
6234 (string-set! (str num char -> void))
6235 (string=? (str str -> bool))
6236 (string<? (str str -> bool))
6237 (string>? (str str -> bool))
6238 (string<=? (str str -> bool))
6239 (string>=? (str str -> bool))
6240 (string-ci=? (str str -> bool))
6241 (string-ci<? (str str -> bool))
6242 (string-ci>? (str str -> bool))
6243 (string-ci<=? (str str -> bool))
6244 (string-ci>=? (str str -> bool))
6245 (substring (str num num -> str))
6246 (string-append ((&list str) -> str))
6247 (string->list (str -> (list char)) (ic))
6248 (list->string ((list char) -> str))
6249 (string-copy (str -> str))
6250 (string-fill! (str char -> void))
6251 (make-vector (num a -> (vec a)) (i))
6252 (vector ((&list a) -> (vec a)) (i))
6253 (vector-length ((vec a) -> num))
6254 (vector-ref ((vec a) num -> a))
6255 (vector-set! ((vec a) num a -> void))
6256 (vector->list ((vec a) -> (list a)) (ic))
6257 (list->vector ((list a) -> (vec a)) (i))
6258 (vector-fill! ((vec a) a -> void))
6259 (apply (((&list a) -> b) (list a) -> b) (i) (d))
6260 (map ((a -> b) (list a) -> (list b)) (i) (d))
6261 (for-each ((a -> b) (list a) -> void) (i) (d))
6262 (force ((promise a) -> a) (i))
6263 (call-with-current-continuation
6264 (((a -> b) -> a) -> a)
6266 (call-with-input-file
6267 (str (iport -> a) -> a)
6269 (call-with-output-file
6270 (str (oport -> a) -> a)
6272 (input-port? (a -> bool))
6273 (output-port? (a -> bool))
6274 (current-input-port (-> iport))
6275 (current-output-port (-> oport))
6276 (with-input-from-file (str (-> a) -> a) (i))
6277 (with-output-to-file (str (-> a) -> a) (i))
6278 (open-input-file (str -> iport))
6279 (open-output-file (str -> oport))
6280 (close-input-port (iport -> void))
6281 (close-output-port (oport -> void))
6282 (read ((&optional iport)
6307 ((&optional iport) -> (+ char eof))
6310 ((&optional iport) -> (+ char eof))
6312 (char-ready? ((&optional iport) -> bool) (i))
6313 (write (a (&optional oport) -> void) (i))
6314 (display (a (&optional oport) -> void) (i))
6315 (newline ((&optional oport) -> void) (i))
6316 (write-char (char (&optional oport) -> void) (i))
6317 (load (str -> void))
6318 (transcript-on (str -> void))
6319 (transcript-off (-> void))
6320 (symbol-append ((&rest a) -> sym))
6321 (box (a -> (box a)) (i))
6322 (unbox ((box a) -> a) (s boxx))
6323 (set-box! ((box a) a -> void))
6325 (make-module (a -> (module a)))
6326 (raise ((&rest a) -> b))
6327 (match:error (a (&rest b) -> c))
6328 (should-never-reach (a -> b))
6329 (make-cvector (num a -> (cvec a)))
6330 (cvector ((&list a) -> (cvec a)))
6331 (cvector-length ((cvec a) -> num))
6332 (cvector-ref ((cvec a) num -> a))
6333 (cvector->list ((cvec a) -> (list a)) (ic))
6334 (list->cvector ((list a) -> (cvec a)))
6335 (,qcons (a b -> (cons a b)) (ic) (n))
6336 (,qvector ((&list a) -> (vec a)) (i) (n))
6337 (,qbox (a -> (box a)) (i) (n))
6338 (,qlist ((&list a) -> (list a)) (ic) (n))
6339 (number? ((+ num x) -> bool) (p (num)))
6340 (null? ((+ nil x) -> bool) (p (nil)))
6341 (char? ((+ char x) -> bool) (p (char)))
6342 (symbol? ((+ sym x) -> bool) (p (sym)))
6343 (string? ((+ str x) -> bool) (p (str)))
6344 (vector? ((+ (vec a) x) -> bool) (p (vec a)))
6345 (cvector? ((+ (cvec a) x) -> bool) (p (cvec a)))
6346 (box? ((+ (box a) x) -> bool) (p (box a)))
6347 (pair? ((+ (cons a b) x) -> bool) (p (cons a b)))
6349 ((+ ((&rest a) -> b) x) -> bool)
6351 (eof-object? ((+ eof x) -> bool) (p (eof)))
6352 (input-port? ((+ iport x) -> bool) (p (iport)))
6353 (output-port? ((+ oport x) -> bool) (p (oport)))
6354 (true-object? ((+ true x) -> bool) (p (true)))
6355 (false-object? ((+ false x) -> bool) (p (false)))
6357 ((+ (module a) x) -> bool)
6359 (boolean? ((+ true false x) -> bool) (p #t))
6360 (list? ((mu u (+ nil (cons y u) x)) -> bool)
6362 (define initial-env '())
6366 (foldr init-prim empty-env initial-info))))
6369 (letrec ((build-selector
6372 ('_ (lambda (x) (make-pany)))
6374 (let ((c (lookup env 'box?)))
6375 (lambda (x) (make-pobj c (list x)))))
6377 (let ((c (lookup env 'pair?))
6378 (lx (build-selector x))
6379 (ly (build-selector y)))
6380 (lambda (x) (make-pobj c (list (lx x) (ly x)))))))))
6383 (let* ((pure (cond ((assq 'i attr) #f)
6384 ((assq 'ic attr) 'cons)
6386 (def (assq 'd attr))
6387 (check (assq 'c attr))
6388 (nocheck (assq 'n attr))
6389 (pred (match (assq 'p attr)
6393 (cons (lookup initial-type-env tag) args))))
6394 (sel (match (assq 's attr)
6396 ((_ s) (build-selector s))))
6402 (closeall (r+ initial-type-env type))
6407 (cond (nocheck 'nocheck)
6418 (symbol-append 'check- name)
6420 (symbol-append 'check- name)
6421 (closeall (r++ initial-type-env type))
6434 (lambda (name type mode)
6436 (r+ initial-type-env type)
6438 (('type . args) (apply syntax-err type args))
6439 (x (apply raise x))))
6440 (let* ((attr (match mode
6443 ('pure-if-cons-is '((ic)))
6445 (set! cons-mutators (cons name cons-mutators))
6448 "invalid attribute ~a for st:defprim"
6450 (info `(,name ,type ,@attr)))
6452 (equal? info (assq name initial-info))
6453 (set! initial-info (cons info initial-info))
6454 (set! initial-env (init-prim info initial-env))))))
6457 (define %not (lookup initial-env 'not))
6458 (define %list (lookup initial-env 'list))
6459 (define %cons (lookup initial-env 'cons))
6460 (define %should-never-reach
6461 (lookup initial-env 'should-never-reach))
6462 (define %false-object?
6463 (lookup initial-env 'false-object?))
6464 (define %eq? (lookup initial-env 'eq?))
6465 (define %eqv? (lookup initial-env 'eqv?))
6466 (define %equal? (lookup initial-env 'equal?))
6467 (define %null? (lookup initial-env 'null?))
6468 (define %vector? (lookup initial-env 'vector?))
6469 (define %cvector? (lookup initial-env 'cvector?))
6470 (define %list? (lookup initial-env 'list?))
6471 (define %boolean? (lookup initial-env 'boolean?))
6473 (lookup initial-env 'procedure?))
6474 (define n-unbound 0)
6476 (lambda (defs env0 tenv0 old-unbound timestamp)
6477 (letrec ((cons-mutable #f)
6480 (lambda (x env context mk-node)
6481 (match (lookup? env x)
6483 (let* ((b (bind-var x)) (n (mk-node b)))
6484 (set-name-timestamp! b context)
6485 (set! unbound (cons n unbound))
6487 (b (when (and (name-primitive b)
6488 (memq x cons-mutators))
6489 (set! cons-mutable #t))
6490 (set-name-occ! b (+ 1 (name-occ b)))
6507 (bind (lambda (e env tenv context)
6508 (let ((bind-cur (lambda (x) (bind x env tenv context))))
6510 (($ var x) (use-var x env context make-var))
6512 (use-var x initial-env context make-var))
6518 (lambda (p) (make-const c p))))
6520 (let* ((b-args (map bind-var args))
6521 (newenv (extend-env* env args b-args)))
6524 (bind e2 newenv tenv context))))
6525 (($ vlam args rest e2)
6526 (let* ((b-args (map bind-var args))
6527 (b-rest (bind-var rest))
6532 (cons b-rest b-args))))
6536 (bind e2 newenv tenv context))))
6537 (($ match e1 clauses)
6541 (bind-mclause x env tenv context))
6544 (make-app (bind-cur e1) (map bind-cur args)))
6545 (($ begin exps) (make-begin (map bind-cur exps)))
6546 (($ and exps) (make-and (map bind-cur exps)))
6547 (($ or exps) (make-or (map bind-cur exps)))
6548 (($ if test then els)
6553 (($ delay e2) (make-delay (bind-cur e2)))
6560 (when (name-struct b)
6563 "define-structure identifier ~a may not be assigned"
6565 (when (name-primitive b)
6568 "(set! ~a ...) requires (define ~a ...)"
6571 (when (and (not (name-mutated b))
6572 (not (= (name-timestamp b)
6576 "(set! ~a ...) missing from compilation unit defining ~a"
6579 (set-name-mutated! b #t)
6580 (make-set! b (bind-cur e2)))))
6592 (map bind-name args)
6593 (map bind-name b-args))))
6596 (bind e2 newenv tenv context))))
6599 ((args args) (b-args '()) (env env))
6601 ((($ bind x e) . rest)
6602 (let ((b (bind-var x)))
6611 (extend-env env x b))))
6615 (bind e2 env tenv context))))))
6620 (make-bind (bind-var x) e)))
6625 (map bind-name args)
6626 (map bind-name b-args)))
6630 (let* ((n (name-occ b))
6640 (bind e2 newenv tenv context))))
6643 (((defs newenv newtenv)
6644 (bind-defn defs env tenv #f)))
6648 (bind x newenv newtenv context))
6655 (make-bind x (bind-cur e))))
6659 (make-field x (bind-cur e2)))
6668 `(rec ,bind (,ty2 -> ,ty2)))
6672 (apply syntax-err ty args))
6673 (x (apply raise x))))))
6676 (bind-cur e2))))))))
6678 (lambda (clause env tenv context)
6680 ((($ mclause pattern body failsym) clause)
6686 (when (bound? patenv x)
6689 "pattern variable ~a repeated"
6691 (let ((b (bind-var x)))
6692 (set! patenv (extend-env patenv x b))
6700 (cond ((boolean? (name-predicate b))
6703 "~a is not a predicate"
6705 ((and (not (eq? b %vector?))
6706 (not (eq? b %cvector?))
6708 (cdr (name-predicate
6713 "~a requires ~a sub-patterns"
6716 (cdr (name-predicate
6721 (map loop args)))))))
6723 (make-pand (map loop pats)))
6724 (($ pnot pat) (make-pnot (loop pat)))
6735 "~a is not a predicate"
6745 (lambda (p) (make-pconst c p))))))))
6747 (let ((b (bind-var failsym)))
6748 (when (bound? patenv failsym)
6751 "fail symbol ~a repeated"
6753 (set! patenv (extend-env patenv failsym b))
6756 (bind body (join-env env patenv) tenv context)
6760 (bind body (join-env env patenv) tenv context)
6763 (lambda (defs env tenv glob)
6764 (let* ((newenv empty-env)
6768 (when (or (bound? newenv x)
6769 (and glob (bound? initial-env x)))
6772 "~a defined more than once"
6774 (let ((b (bind-var x)))
6775 (set-name-primitive! b #t)
6776 (set-name-struct! b #t)
6777 (set-name-pure! b pure)
6778 (set! newenv (extend-env newenv x b))
6780 (bind1 (match-lambda
6781 ((and z ($ define x e))
6785 (make-define #f (make-set! x e))
6788 "~a defined more than once"
6791 (let ((b (bind-var x)))
6792 (set-name-gdef! b glob)
6794 (extend-env newenv x b))
6795 (make-define b e)))))
6807 (let* ((make (struct-def
6810 (pred (struct-def pred #t))
6815 (let ((b (struct-def
6834 (some (struct-def x #t)))
6836 (get (map-with-n bind-get get))
6837 (getn (map-with-n bind-get getn))
6838 (set (map bind-set set))
6839 (setn (map bind-set setn))
6840 (_ (when (bound? newtenv tag)
6843 "type constructor ~a defined more than once"
6853 (set! newtenv (extend-env newtenv tag tc))
6854 (set-name-predicate!
6856 `(,tc ,@(map (lambda (_) (gensym)) get)))
6867 ((and d ($ datatype dt))
6869 (maplr (match-lambda
6870 (((tag . args) . bindings)
6871 (when (bound? newtenv tag)
6874 "type constructor ~a defined more than once"
6876 (let ((tc (bind-tycon
6878 (map (lambda (_) #f)
6886 (extend-env newtenv tag tc))
6887 (cons (cons tc args)
6888 (maplr (match-lambda
6893 (let ((make (struct-def
6899 (set-name-predicate!
6912 (defs2 (maplr bind1 defs))
6913 (newenv2 (join-env env newenv))
6914 (newtenv2 (join-env tenv newtenv))
6915 (bind2 (match-lambda
6916 ((and ($ define (? name? x) ($ var y)))
6918 (if (eq? (name-name x) y)
6919 (if (bound? initial-env y)
6922 (make-var (lookup initial-env y)))
6925 "Warning: (define ~a ~a) but ~a is not a primitive~%"
6931 ((and ($ define x e2) context)
6938 "Note: (define ~a ...) hides primitive ~a~%"
6943 (let ((b (bind-var x)))
6944 (set-name-gdef! b glob)
6946 (bind e2 newenv2 newtenv2 context)))
6948 (list (maplr bind2 defs2) newenv2 newtenv2))))
6953 (match (lookup? env (name-name x))
6954 (#f (set! unbound (cons e unbound)))
6955 (b (when (and (name-primitive b)
6956 (memq x cons-mutators))
6957 (set! cons-mutable #t))
6958 (set-name-occ! b (+ 1 (name-occ b)))
6959 (set-var-name! e b))))
6961 (match (lookup? env (name-name x))
6962 (#f (set! unbound (cons e unbound)))
6963 (b (when (name-struct b)
6966 "define-structure identifier ~a may not be assigned"
6968 (when (name-primitive b)
6971 "(set! ~a ...) requires (define ~a ...)"
6974 (when (and (not (name-mutated b))
6975 (not (= (name-timestamp b)
6979 "(set! ~a ...) missing from compilation unit defining ~a"
6982 (set-name-mutated! b #t)
6983 (set-name-occ! b (+ 1 (name-occ b)))
6984 (set-set!-name! e b))))))))
6986 (((defs env tenv) (bind-defn defs env0 tenv0 #t)))
6988 (lambda (x) (bind-old x env))
6990 (set-cons-mutability! cons-mutable)
6991 (set! n-unbound (length unbound))
6992 (list defs env tenv unbound)))))
7008 (define warn-unbound
7019 (memq (name-name b) names)
7020 (set! names (cons (name-name b) names))
7022 "Warning: ~a is unbound in "
7024 (print-context (pexpr (name-timestamp b)) 2)))))
7025 (for-each (lambda (x) (warn (node->name x))) l))))
7026 (define name-unbound?
7027 (lambda (x) (not (number? (name-timestamp x)))))
7028 (define improve-defs
7031 (($ define x e2) (make-define x (improve e2)))
7036 (($ match e clauses) (improve-match e clauses))
7037 (($ if tst thn els) (improve-if tst thn els))
7040 (($ lam args e2) (make-lam args (improve e2)))
7041 (($ vlam args rest e2)
7042 (make-vlam args rest (improve e2)))
7043 (($ app (and e1 ($ var x)) args)
7044 (let ((args (map improve args)))
7045 (if (and (eq? x %list) (< (length args) conslimit))
7046 (foldr (lambda (a rest)
7047 (make-app (make-var %cons) (list a rest)))
7048 (make-const '() %null?)
7050 (make-app e1 args))))
7052 (make-app (improve e1) (map improve args)))
7053 (($ begin exps) (make-begin (map improve exps)))
7054 (($ and exps) (make-and (map improve exps)))
7055 (($ or exps) (make-or (map improve exps)))
7056 (($ delay e2) (make-delay (improve e2)))
7057 (($ set! x e2) (make-set! x (improve e2)))
7059 (let ((args (map (match-lambda
7060 (($ bind x e) (make-bind x (improve e))))
7062 (make-let args (improve e2))))
7064 (let ((args (map (match-lambda
7065 (($ bind x e) (make-bind x (improve e))))
7067 (make-let* args (improve e2))))
7069 (let ((args (map (match-lambda
7070 (($ bind x e) (make-bind x (improve e))))
7072 (make-letr args (improve e2))))
7074 (let ((defs (improve-defs defs)))
7075 (make-body defs (map improve exps))))
7079 (($ bind x e) (make-bind x (improve e))))
7081 (($ field x e2) (make-field x (improve e2)))
7082 (($ cast ty e2) (make-cast ty (improve e2)))))
7084 (lambda (tst thn els)
7086 (lambda (x p mk-s thn els)
7089 (($ app ($ var q) _)
7090 (if (eq? q %should-never-reach)
7097 (mk-s (make-ppred p))
7098 (make-body '() (list thn))
7102 (make-body '() (list els))
7105 (($ app ($ var v) (e))
7107 (if (eq? v %not) (improve-if e els thn) (fail)))
7108 (($ app ($ var eq) (($ const #f _) val))
7110 (if (or (eq? eq %eq?)
7113 (improve-if val els thn)
7115 (($ app ($ var eq) (val ($ const #f _)))
7117 (if (or (eq? eq %eq?)
7120 (improve-if val els thn)
7122 (($ app ($ var v) (($ var x)))
7124 (if (and (name-predicate v) (not (name-mutated x)))
7125 (improve (if->match x v (lambda (x) x) thn els))
7127 (($ app ($ var v) (($ app ($ var s) (($ var x)))))
7129 (if (and (name-predicate v)
7131 (not (name-mutated x)))
7133 (if->match x v (name-selector s) thn els))
7135 (($ app ($ var v) (($ var x)))
7137 (if (and (name-selector v) (not (name-mutated x)))
7148 (if (not (name-mutated v))
7161 (define improve-match
7165 (($ mclause p body fail)
7166 (make-mclause p (improve body) fail)))
7170 (if (not (name-mutated x))
7173 ((and c ($ mclause p e fail))
7174 (if (not (uses-x? e x))
7176 (let ((y (rebind-var x)))
7178 (make-flat-pand (list p (make-pvar y)))
7181 (make-match e (map fix-clause clauses)))
7182 (make-match e clauses)))
7183 (_ (make-match (improve e) clauses))))))
7189 (($ and exps) (ormap loop exps))
7191 (or (loop fun) (ormap loop args)))
7192 (($ begin exps) (ormap loop exps))
7194 (or (loop e1) (loop e2) (loop e3)))
7195 (($ lam names body) (loop body))
7196 (($ let bindings body)
7197 (or (ormap (match-lambda (($ bind _ b) (loop b)))
7200 (($ let* bindings body)
7201 (or (ormap (match-lambda (($ bind _ b) (loop b)))
7204 (($ letr bindings body)
7205 (or (ormap (match-lambda (($ bind _ b) (loop b)))
7208 (($ or exps) (ormap loop exps))
7209 (($ delay e2) (loop e2))
7210 (($ set! name exp) (or (eq? x name) (loop exp)))
7211 (($ var name) (eq? x name))
7212 (($ vlam names name body) (loop body))
7213 (($ match exp clauses)
7215 (ormap (match-lambda
7216 (($ mclause p b _) (or (loop p) (loop b))))
7219 (or (ormap loop defs) (ormap loop exps)))
7220 (($ record bindings)
7221 (ormap (match-lambda (($ bind _ b) (loop b)))
7223 (($ field _ e) (loop e))
7224 (($ cast _ e) (loop e))
7225 (($ define _ e) (loop e))
7228 (($ pand pats) (ormap loop pats))
7229 (($ pnot pat) (loop pat))
7230 (($ pobj c args) (ormap loop args))
7231 (($ ppred pred) (eq? x pred))
7235 (let ((dos (lambda (y) (if (eq? x y) to y))))
7239 (($ define x e) (make-define x (sub e)))
7242 (($ match e clauses)
7245 (($ mclause p e fail)
7246 (make-mclause p (sub e) fail)))
7248 (make-match (sub e) clauses)))
7250 (make-if (sub tst) (sub thn) (sub els)))
7251 (($ var x) (make-var (dos x)))
7253 (($ lam args e2) (make-lam args (sub e2)))
7254 (($ vlam args rest e2)
7255 (make-vlam args rest (sub e2)))
7257 (make-app (sub e1) (map sub args)))
7258 (($ begin exps) (make-begin (map sub exps)))
7259 (($ and exps) (make-and (map sub exps)))
7260 (($ or exps) (make-or (map sub exps)))
7261 (($ delay e2) (make-delay (sub e2)))
7262 (($ set! x e2) (make-set! (dos x) (sub e2)))
7264 (let ((args (map (match-lambda
7265 (($ bind x e) (make-bind x (sub e))))
7267 (make-let args (sub e2))))
7269 (let ((args (map (match-lambda
7270 (($ bind x e) (make-bind x (sub e))))
7272 (make-let* args (sub e2))))
7274 (let ((args (map (match-lambda
7275 (($ bind x e) (make-bind x (sub e))))
7277 (make-letr args (sub e2))))
7279 (make-body (map sub defs) (map sub exps)))
7283 (($ bind x e) (make-bind x (sub e))))
7285 (($ field x e) (make-field x (sub e)))
7286 (($ cast ty e) (make-cast ty (sub e))))))))
7287 (define improve-clauses
7294 (((and m1 ($ mclause p _ fail)) . rest)
7299 ((clauses (loop rest)))
7302 (((and m ($ mclause p2 body2 fail2))
7305 (match (improve-by-pattern p2 p)
7316 "Warning: redundant pattern ~a~%"
7328 (loop2 r))))))))))))))
7329 (define improve-by-pattern
7331 (call-with-current-continuation
7333 (let* ((reject (lambda () (k (cons 'continue p2))))
7338 '(printf "(M ~a ~a)~%" (ppat p1) (ppat p2))
7340 ((($ pand (a . _)) . p2) (m a p2))
7341 ((p1 $ pand (a . b))
7342 (make-flat-pand (cons (m p1 a) b)))
7345 (or (pvar? p2) (pany? p2))
7350 (or (pvar? p2) (pany? p2))
7355 (or (pvar? p2) (pany? p2))
7359 (unless p1covers (reject))
7361 (make-flat-pand (list p2 (make-pnot p1))))
7363 (unless p1covers (reject))
7365 (make-flat-pand (list p2 (make-pnot p1))))
7367 (unless p1covers (reject))
7369 (make-flat-pand (list p2 (make-pnot p1))))
7370 ((($ pconst a _) $ pconst b _)
7371 (unless (equal? a b) (reject))
7373 ((($ pobj tag1 a) $ pobj tag2 b)
7374 (unless (eq? tag1 tag2) (reject))
7375 (make-pobj tag1 (map2 m a b)))
7376 ((($ ppred tag1) $ ppred tag2)
7377 (unless (eq? tag1 tag2) (reject))
7379 ((($ ppred tag1) $ pobj tag2 _)
7380 (unless (eq? tag1 tag2) (reject))
7383 ((($ ppred tag1) $ pconst c tag2)
7384 (unless (eq? tag1 tag2) (reject))
7388 (cond (p1covers (cons 'redundant p2))
7389 (p2covers (cons 'stop p3))
7390 (else (cons 'continue p3))))))))
7391 (define improve-by-noisily
7393 (let ((r (improve-by-pattern p2 p1)))
7395 "~a by ~a returns ~a ~a~%"
7400 (define make-components
7404 (match-lambda ((? define?) #f) (x x))
7407 (match-lambda ((? define? x) x) (_ #f))
7409 (name-of (match-lambda (($ define x _) x)))
7412 (($ define _ e) (references e name-gdef))))
7413 (comp (top-sort defs name-of ref-of)))
7415 (printf "Components:~%")
7419 (($ define x _) (and x (name-name x))))
7422 (append structs comp))))
7423 (define make-body-components
7427 (match-lambda ((? define?) #f) (x x))
7430 (match-lambda ((? define? x) x) (_ #f))
7432 (name-of (match-lambda (($ define x _) x)))
7433 (bound (map name-of defs))
7437 (references e (lambda (x) (memq x bound))))))
7438 (comp (top-sort defs name-of ref-of)))
7440 (printf "Components:~%")
7444 (($ define x _) (and x (name-name x))))
7447 (append structs comp))))
7448 (define make-letrec-components
7450 (let* ((name-of bind-name)
7451 (bound (map name-of bindings))
7455 (references e (lambda (x) (memq x bound))))))
7456 (comp (top-sort bindings name-of ref-of)))
7458 (printf "Letrec Components:~%")
7461 (map (match-lambda (($ bind x _) (pname x))) c))
7470 (if (and x (name-mutated x))
7471 (union (set x) (loop e))
7473 ((? defstruct?) empty-set)
7474 ((? datatype?) empty-set)
7475 ((? const?) empty-set)
7476 (($ var x) (if (ref? x) (set x) empty-set))
7477 (($ lam _ e1) (loop e1))
7478 (($ vlam _ _ e1) (loop e1))
7480 (foldr union2 (loop e0) (map loop args)))
7482 (let ((do-bind (match-lambda (($ bind _ e) (loop e)))))
7483 (foldr union2 (loop e2) (map do-bind b))))
7485 (let ((do-bind (match-lambda (($ bind _ e) (loop e)))))
7486 (foldr union2 (loop e2) (map do-bind b))))
7488 (let ((do-bind (match-lambda (($ bind _ e) (loop e)))))
7489 (foldr union2 (loop e2) (map do-bind b))))
7493 (map loop (append defs exps))))
7495 (let ((do-bind (match-lambda (($ bind _ e) (loop e)))))
7496 (foldr union2 empty-set (map do-bind b))))
7497 (($ field _ e) (loop e))
7498 (($ cast _ e) (loop e))
7500 (foldr union2 empty-set (map loop exps)))
7502 (foldr union2 empty-set (map loop exps)))
7504 (foldr union2 empty-set (map loop exps)))
7505 (($ if test then els)
7506 (union (loop test) (loop then) (loop els)))
7507 (($ delay e) (loop e))
7509 (union (if (ref? x) (set x) empty-set)
7511 (($ match exp clauses)
7514 (map (match-lambda (($ mclause _ exp _) (loop exp)))
7517 (lambda (graph name-of references-of)
7521 (box (references-of x))
7525 (gt (let ((gt (map (match-lambda
7527 (list n (box empty-set) (box #f) n)))
7536 ((_ b _ _) (set-box! b (cons n (unbox b))))))
7541 (letrec ((visit (lambda (g l)
7550 (foldr (lambda (v l)
7555 (unbox nay))))))))))
7557 (visit-gt (visit gt))
7559 (post (foldr visit-gt '() gt))
7560 (pre (foldl (lambda (gg l)
7561 (match (visit-g (adj gg g) '())
7568 (define genmatch #t)
7574 ((? defstruct? b) (type-structure b))
7575 ((? datatype? b) (type-structure b))
7576 (c (type-component c #t)))
7577 (make-components d))
7579 (define type-structure
7591 (let* ((vars (map (lambda (_) (gensym)) get))
7599 (r+ initial-type-env `((,x ,@vars) -> ,v)))))
7608 (r+ initial-type-env `((,x ,@vars) ,v -> void)))))
7613 (r+ initial-type-env `(,@vars -> (,x ,@vars)))))
7617 (r+ initial-type-env
7618 `((+ (,x ,@vars) y) -> bool))))
7619 (for-each2 make-get-type get vars)
7620 (for-each2 make-set-type set vars)
7621 (for-each2 make-get-type getn vars)
7622 (for-each2 make-set-type setn vars)))
7629 (($ variant con pred arg-types)
7633 (r+ initial-type-env
7634 `(,@(cdr arg-types) -> ,type))))
7638 (r+ initial-type-env
7639 `((+ ,(name-predicate pred) x) -> bool))))))
7642 (define type-component
7643 (lambda (component top)
7647 (match-lambda (($ define b _) (name-name b)))
7651 (printf "Typing ~a~%" cnames))))
7652 (let* ((f (match-lambda (($ define b e) (make-bind b e))))
7653 (bindings (map f component))
7654 (names (map (match-lambda (($ define b _) (pname b)))
7657 (($ define b _) (set-name-ty! b (tvar)))))
7659 ((and d ($ define b e))
7660 (set-define-exp! d (w e names)))))
7662 (($ define b e) (unify (name-ty b) (typeof e)))))
7663 (f4 (match-lambda (($ define b _) (name-ty b))))
7665 (match d (($ define b _) (set-name-ty! b ts))))))
7667 (for-each f1 component)
7668 (for-each f2 component)
7669 (for-each f3 component)
7670 (for-each limit-expansive component)
7674 (close (map f4 component)))
7677 (lambda (e component)
7681 (r+ initial-type-env (name-predicate pred))
7688 (if (name-mutated x)
7690 (let* ((_1 (push-level))
7691 (t (closeall (tvar)))
7694 (if (ts? (name-ty x))
7696 ((tynode (make-type #f #f))
7697 ((t absv) (instantiate (name-ty x) tynode)))
7698 (set-type-ty! tynode t)
7701 (match (name-primitive x)
7703 (make-check (list absv #f #f #f component) e))
7706 (list (cons top absv) #f #f #f component)
7711 (list absv (mk-definite-prim t) #f #f component)
7714 (make-check (list absv #f #f #t component) e))))
7718 (for-each (lambda (b) (set-name-ty! b (tvar))) x)
7720 ((body (w e1 component))
7724 `(,@(map name-ty x) -> ,(typeof body)))))
7728 (list absv (mk-definite-lam t) #f #f component)
7729 (make-lam x body)))))
7731 (for-each (lambda (b) (set-name-ty! b (tvar))) x)
7736 (r+ initial-type-env `(list ,z))))
7737 (body (w e1 component))
7741 `(,@(map name-ty x) (&list ,z) -> ,(typeof body)))))
7745 (list absv (mk-definite-lam t) #f #f component)
7746 (make-vlam x rest body)))))
7749 ((t0 (w e0 component))
7750 (targs (maplr (lambda (e) (w e component)) args))
7751 (a* (map (lambda (_) (tvar)) args))
7754 (r-collect initial-type-env `(,@a* -> ,b)))
7755 (definf (mk-definite-app t)))
7756 (unify (typeof t0) t)
7757 (for-each2 unify (map typeof targs) a*)
7758 (if (syntactically-a-procedure? t0)
7759 (make-type b (make-app t0 targs))
7763 (list absv definf #f #f component)
7764 (make-app t0 targs))))))
7770 (let* ((_ (push-level))
7771 (e (w e (list (pname b))))
7772 (bind (make-bind b e)))
7773 (limit-expansive bind)
7774 (set-name-ty! b (car (close (list (typeof e)))))
7777 (let ((e (w e component)))
7778 (set-name-ty! b (typeof e))
7779 (make-bind b e))))))
7780 (tb (map do-bind b))
7781 (body (w e2 component)))
7782 (make-let tb body)))
7788 (let* ((_ (push-level))
7789 (e (w e (list (pname b))))
7790 (bind (make-bind b e)))
7791 (limit-expansive bind)
7792 (set-name-ty! b (car (close (list (typeof e)))))
7795 (let ((e (w e component)))
7796 (set-name-ty! b (typeof e))
7797 (make-bind b e))))))
7798 (tb (maplr do-bind b))
7799 (body (w e2 component)))
7800 (make-let* tb body)))
7805 (let* ((f1 (match-lambda
7806 (($ bind b _) (set-name-ty! b (tvar)))))
7807 (names (map (match-lambda
7808 (($ bind b _) (pname b)))
7812 (make-bind b (w e names)))))
7815 (unify (name-ty b) (typeof e))
7817 (f4 (lambda (bind ts)
7820 (set-name-ty! b ts)))))
7822 (_2 (for-each f1 b))
7824 (_3 (for-each limit-expansive tb))
7825 (ts-list (close (maplr f3 tb))))
7827 (for-each2 f4 tb ts-list)
7829 (let* ((f1 (match-lambda
7830 (($ bind b _) (set-name-ty! b (tvar)))))
7833 (make-bind b (w e component)))))
7836 (unify (name-ty b) (typeof e)))))
7837 (_1 (for-each f1 b))
7841 (comps (make-letrec-components b))
7842 (tb (foldr append '() (maplr do-comp comps))))
7843 (make-letr tb (w e2 component))))
7847 ((? defstruct? b) (type-structure b))
7848 ((? datatype? b) (type-structure b))
7849 (c (type-component c #f)))
7850 (make-body-components defs))
7851 (let ((texps (maplr (lambda (x) (w x component)) exps)))
7852 (make-body defs texps)))
7854 (let* ((texps (maplr (lambda (x) (w x component)) exps))
7856 (() (r+ initial-type-env 'true))
7858 (_ (let ((a (r+ initial-type-env 'false)))
7859 (unify (typeof (rac texps)) a)
7861 (make-type t (make-and texps))))
7863 (let* ((texps (maplr (lambda (x) (w x component)) exps))
7865 (() (r+ initial-type-env 'false))
7867 (_ (let* ((t-last (typeof (rac texps)))
7868 (but-last (rdc texps))
7873 (r+ initial-type-env
7874 `(+ (not false) ,a))))
7877 (r+ initial-type-env
7878 `(+ (not false) ,a)))
7880 (make-type t (make-or texps))))
7882 (let ((texps (maplr (lambda (x) (w x component)) exps)))
7883 (make-begin texps)))
7884 (($ if test then els)
7885 (let ((ttest (w test component))
7886 (tthen (w then component))
7887 (tels (w els component))
7889 (unify (typeof tthen) a)
7890 (unify (typeof tels) a)
7891 (make-type a (make-if ttest tthen tels))))
7893 (let ((texp (w e2 component)))
7895 (r+ initial-type-env `(promise ,(typeof texp)))
7896 (make-delay texp))))
7898 (unless (name-ty x) (set-name-ty! x (monotvar)))
7899 (let* ((body (w body component))
7900 (t (if (ts? (name-ty x))
7901 (car (instantiate (name-ty x) #f))
7903 (unify t (typeof body))
7905 (r+ initial-type-env 'void)
7906 (make-set! x body))))
7908 (let* ((tbind (map (match-lambda
7910 (make-bind name (w exp component))))
7912 (t (r+ initial-type-env
7914 ,@(map (match-lambda
7916 (list name (typeof exp))))
7918 (make-type t (make-record tbind))))
7921 ((texp (w exp component))
7924 (r-collect initial-type-env `(record (,name ,a)))))
7925 (unify (typeof texp) t)
7929 (list absv #f #f #f component)
7930 (make-field name texp)))))
7931 (($ cast (ty t absv) exp)
7932 (let ((texp (w exp component)) (a (tvar)))
7933 (unify (r+ initial-type-env `(,(typeof texp) -> ,a))
7938 (list absv #f #f #f component)
7939 (make-cast (list ty t absv) texp)))))
7940 (($ match exp clauses)
7943 (($ mclause p _ (? name? fail))
7946 (r+ initial-type-env '(a ?-> b))))
7954 (list (make-mclause (make-pelse) #f #f)))))
7955 ((tmatch absv precise)
7956 (w-match (rdc iclauses) (rac iclauses)))
7957 (texp (w exp component))
7958 (_ (unify (typeof texp) tmatch))
7960 (maplr (match-lambda
7961 (($ mclause p e fail)
7962 (make-mclause p (w e component) fail)))
7967 (($ mclause _ e _) (unify (typeof e) a)))
7972 (list absv #f (not precise) #f component)
7973 (make-match texp tclauses))))))))
7975 (lambda (clauses last)
7976 (letrec ((bindings '())
7979 (($ pand pats) (encode* pats))
7980 (x (encode* (list x)))))
7985 (or (pconst? p) (pobj? p) (ppred? p) (pelse? p))))
7986 (var? (lambda (p) (or (pvar? p) (pany? p))))
7989 (and (not (pvar? p)) (not (pany? p)))))
7990 (t (match (filter concrete? pats)
7992 (r+ initial-type-env
7997 (r+ initial-type-env
8003 ,@(if (null? (filter var? pats))
8005 (list (out1tvar)))))))))
8009 (set! bindings (cons b bindings))
8010 (set-name-ty! b (pat-var-bind t))))
8011 (filter pvar? pats))
8016 (($ pconst _ pred) (list (name-predicate pred)))
8017 ((and pat ($ pobj c args))
8018 (list (cond ((or (eq? %vector? c) (eq? %cvector? c))
8019 (cons (if (eq? %vector? c) 'vec 'cvec)
8020 (match (maplr encode args)
8021 (() (list (out1tvar)))
8023 (list (foldr (lambda (x y)
8029 (cons (car (name-predicate c))
8030 (maplr encode args))))))
8032 (cond ((eq? pred %boolean?) (list 'true 'false))
8033 ((eq? pred %list?) (list `(list ,(out1tvar))))
8035 (list (cons (car (name-predicate pred))
8036 (maplr (lambda (_) (out1tvar))
8037 (cdr (name-predicate pred))))))))
8038 (($ pnot (? pconst?)) '())
8039 (($ pnot ($ ppred pred))
8040 (cond ((eq? pred %boolean?) '((not true) (not false)))
8041 ((eq? pred %procedure?) '((not ?->)))
8042 ((eq? pred %list?) '())
8043 (else `((not ,(car (name-predicate pred)))))))
8044 (($ pnot ($ pobj pred pats))
8045 (let ((m (foldr + 0 (map non-triv pats))))
8047 ((0) `((not ,(car (name-predicate pred)))))
8049 `((,(car (name-predicate pred))
8050 ,@(map (match-lambda
8052 `(+ (not ,(car (name-predicate pred)))
8055 `(+ (not ,(car (name-predicate pred)))
8066 (($ pobj _ pats) (foldr + 1 (map non-triv pats)))
8071 (($ pand pats) (andmap precise pats))
8072 (($ pnot pat) (precise pat))
8074 (let ((m (foldr + 0 (map non-triv pats))))
8077 ((1) (andmap precise pats))
8079 (($ ppred pred) (not (eq? pred %list?)))
8085 (match-lambda (($ mclause _ _ fail) (not fail)))
8087 (match last (($ mclause p _ _) (precise p)))))
8088 (types (maplr (match-lambda (($ mclause p _ _) (encode p)))
8092 (foldr (lambda (x y) (unify x y) y) (tvar) types))))
8093 (unify (out1tvar) t)
8094 (for-each limit-name bindings)
8098 (close (map name-ty bindings)))
8102 ,@(map (match-lambda (($ mclause p _ _) (ppat p)))
8107 ,@(map (lambda (b) (list (pname b) (ptype (name-ty b))))
8109 (list t absv precise-match)))))
8110 (define syntactically-a-procedure?
8112 (($ type _ e) (syntactically-a-procedure? e))
8113 (($ check _ e) (syntactically-a-procedure? e))
8114 (($ var x) (name-primitive x))
8118 (syntactically-a-procedure? body))
8120 (syntactically-a-procedure? body))
8122 (syntactically-a-procedure? body))
8124 (and (syntactically-a-procedure? e2)
8125 (syntactically-a-procedure? e3)))
8127 (syntactically-a-procedure? (rac exps)))
8129 (syntactically-a-procedure? (rac exps)))
8134 (($ check _ e) (typeof e))
8135 (($ let _ body) (typeof body))
8136 (($ let* _ body) (typeof body))
8137 (($ letr _ body) (typeof body))
8138 (($ body _ exps) (typeof (rac exps)))
8139 (($ begin exps) (typeof (rac exps)))
8140 (($ var x) (name-ty x))))
8143 (when (name-mutated n)
8144 (unify (name-ty n) (out1tvar)))))
8145 (define limit-expansive
8146 (letrec ((limit! (lambda (t) (unify t (out1tvar))))
8150 (($ pvar x) (name-mutated x))
8151 (($ pobj _ pats) (ormap expansive-pattern? pats))
8154 (($ pand pats) (ormap expansive-pattern? pats))
8155 (($ ppred x) (name-mutated x))
8156 (($ pnot pat) (expansive-pattern? pat))))
8160 (if (name-mutated b)
8166 (if (and x (name-mutated x))
8171 ($ app ($ type _ ($ check _ ($ var x))) exps))
8172 (cond ((list? (name-pure x))
8173 (if (= (length (name-pure x)) (length exps))
8176 (if pure (limit-expr e) (limit! (typeof e))))
8180 ((or (eq? #t (name-pure x))
8181 (and (eq? 'cons (name-pure x))
8182 (not cons-is-mutable)))
8183 (for-each limit-expr exps))
8185 (($ type t ($ app _ _)) (limit! t))
8186 (($ type t ($ check _ ($ app _ _))) (limit! t))
8188 (($ type t ($ set! _ _)) (limit! t))
8195 (for-each limit-expr bind))
8198 (for-each limit-expr bind))
8201 (for-each limit-expr bind))
8203 (for-each limit-expr defs)
8204 (for-each limit-expr exps))
8205 (($ and exps) (for-each limit-expr exps))
8206 (($ or exps) (for-each limit-expr exps))
8207 (($ begin exps) (for-each limit-expr exps))
8214 (match-lambda (($ bind _ e) (limit-expr e)))
8216 (($ field _ exp) (limit-expr exp))
8217 (($ cast _ exp) (limit-expr exp))
8218 (($ match exp clauses)
8222 (($ mclause pat body fail)
8223 (if (or (and fail (name-mutated fail))
8224 (expansive-pattern? pat))
8225 (limit! (typeof body))
8226 (limit-expr body))))
8228 (($ type _ e1) (limit-expr e1))
8229 (($ check _ e1) (limit-expr e1)))))
8232 (lambda (e check-action)
8233 (letrec ((pbind (match-lambda
8234 (($ bind n e) (list (pname n) (pexpr e)))))
8235 (pexpr (match-lambda
8236 ((and x ($ type _ (? check?)))
8237 (check-action x pexpr))
8238 (($ type _ exp) (pexpr exp))
8239 (($ shape t exp) (pexpr exp))
8241 (if (or (not x) (and (name? x) (not (name-name x))))
8243 `(define ,(pname x) ,(pexpr e))))
8244 (($ defstruct _ args _ _ _ _ _ _ _)
8245 `(check-define-const-structure ,args))
8248 ,@(map (match-lambda
8249 (((tag . args) . bindings)
8250 (cons (cons (ptag tag) args)
8252 (($ variant _ _ types) types))
8255 (($ and exps) `(and ,@(maplr pexpr exps)))
8256 (($ or exps) `(or ,@(maplr pexpr exps)))
8257 (($ begin exps) `(begin ,@(maplr pexpr exps)))
8258 (($ var x) (pname x))
8259 (($ prim x) (pname x))
8260 (($ const x _) (pconst x))
8262 `(lambda ,(maplr pname x) ,@(pexpr e1)))
8264 `(lambda ,(append (maplr pname x) (pname rest))
8266 (($ match e1 clauses)
8269 (($ mclause p #f #f)
8270 `(,(ppat p) <last clause>))
8271 (($ mclause p exp fail)
8276 `(,(ppat p) ,@(pexpr exp))))))
8278 `(match ,p1 ,@(maplr pclause clauses))))
8280 (let* ((p1 (pexpr e1))
8281 (pargs (maplr pexpr args))
8291 ((? vector? x) x))))
8292 (cond ((eq? p1 qlist) `',(maplr unkwote pargs))
8294 (let ((unq (maplr unkwote pargs)))
8295 `',(cons (car unq) (cadr unq))))
8296 ((eq? p1 qbox) (box (unkwote (car pargs))))
8298 (list->vector (maplr unkwote pargs)))
8299 (else (cons p1 pargs)))))
8301 (let ((pb (maplr pbind b)))
8302 `(let ,pb ,@(pexpr e2))))
8304 (let ((pb (maplr pbind b)))
8305 `(let* ,pb ,@(pexpr e2))))
8307 (let ((pb (maplr pbind b)))
8308 `(letrec ,pb ,@(pexpr e2))))
8310 (let ((pdefs (maplr pexpr defs)))
8311 (append pdefs (maplr pexpr exps))))
8313 (let* ((p1 (pexpr e1)) (p2 (pexpr e2)) (p3 (pexpr e3)))
8315 (($ record bindings)
8316 `(record ,@(maplr pbind bindings)))
8317 (($ field x e2) `(field ,x ,(pexpr e2)))
8318 (($ cast (ty . _) e2) `(: ,ty ,(pexpr e2)))
8319 (($ delay e) `(delay ,(pexpr e)))
8320 (($ set! x e) `(set! ,(pname x) ,(pexpr e))))))
8328 (($ type _ ($ check _ exp)) (pexpr exp)))))))
8332 (($ pconst x _) (pconst x))
8333 (($ pvar x) (pname x))
8336 (($ pnot pat) `(not ,(ppat pat)))
8337 (($ pand pats) `(and ,@(maplr ppat pats)))
8345 (match (cons (pname tag) args)
8346 (('box? x) (box (ppat x)))
8347 (('pair? x y) (cons (ppat x) (ppat y)))
8348 (('vector? . x) (list->vector (maplr ppat x)))
8349 ((tg . _) `($ ,(strip-? tg) ,@(maplr ppat args)))))))
8352 (let* ((str (symbol->string s))
8353 (n (string-length str)))
8355 (not (char=? #\? (string-ref str (- n 1)))))
8357 (string->symbol (substring str 0 (- n 1)))))))
8360 ((? name? x) (or (name-name x) '<expr>))
8364 ((? k? k) (k-name k))
8368 ((? symbol? x) `',x)
8373 ((? null? x) `',x)))
8376 (output-checked file '() type-check?)))
8379 (output-checked #f '() type-check?)
8382 (make-counters total-possible)
8386 (let ((check? (lambda (_) #t)))
8387 (output-checked #f '() check?)
8390 (make-counters total-possible)
8392 (define make-counters
8394 (let* ((init `(define check-counters (make-vector ,n 0)))
8395 (sum '(define check-total
8397 (let ((foldr (lambda (f i l)
8402 ((x . y) (f x (loop y))))))))
8403 (foldr + 0 (vector->list check-counters))))))
8404 (incr '(extend-syntax
8405 (check-increment-counter)
8406 ((check-increment-counter c)
8410 (+ 1 (vector-ref check-counters c)))))))
8411 (list init sum incr))))
8412 (define output-checked
8413 (lambda (file header check-test)
8415 (set! total-possible 0)
8419 (let ((doit (lambda ()
8420 (when (string? file)
8422 ";; Generated by Soft Scheme ~a~%"
8424 (printf ";; (st:control")
8426 (lambda (x) (printf " '~a" x))
8432 ";; CAUTION: ~a unbound references, this code is not safe~%"
8435 (for-each pretty-print header))
8444 (set! n-inexhaust 0)
8451 (pretty-print (pcheck exp check-test))
8452 (pcheck exp check-test))
8453 (make-summary-line x)
8454 (set! total-possible
8455 (+ total-possible n-possible))
8456 (set! total-cast (+ total-cast n-cast))
8457 (set! total-err (+ total-err n-err))
8469 (pcheck exp check-test))))))
8471 (when (string? file)
8474 (print-summary "; ")))))
8478 (with-output-to-file file doit))
8480 (define total-possible 0)
8481 (define total-err 0)
8482 (define total-cast 0)
8483 (define total-any 0)
8484 (define n-possible 0)
8488 (define n-inexhaust 0)
8494 (define summary '())
8495 (define make-summary-line
8497 (let ((total (+ n-match
8510 (s (cond ((< 0 n-inexhaust)
8512 "~a (~a match ~a inexhaust)"
8517 (sprintf "~a (~a match)" s n-match))
8520 (sprintf "~a (~a prim)" s n-prim)
8522 (s (if (< 0 n-field)
8523 (sprintf "~a (~a field)" s n-field)
8526 (sprintf "~a (~a lambda)" s n-lam)
8528 (s (if (< 0 n-app) (sprintf "~a (~a ap)" s n-app) s))
8530 (sprintf "~a (~a ERROR)" s n-err)
8533 (sprintf "~a (~a TYPE)" s n-cast)
8535 (set! summary (cons s summary)))))))
8536 (define print-summary
8539 (lambda (s) (printf "~a~a~%" hdr s))
8544 (padr "TOTAL CHECKS" 16)
8549 (if (= 0 total-possible)
8554 (* (/ total-any total-possible) 100))
8556 (when (< 0 total-err)
8557 (printf " (~s ERROR)" total-err))
8558 (when (< 0 total-cast)
8559 (printf " (~s TYPE)" total-cast))
8563 (let ((s (sprintf "~a" arg)))
8566 (if (< (string-length s) n)
8567 (loop (string-append " " s))
8571 (let ((s (sprintf "~a" arg)))
8574 (if (< (string-length s) n)
8575 (loop (string-append s " "))
8580 (sprintf "~s00000000000000000000" x)
8584 (lambda (ex check-test)
8589 ((and z ($ type _ ($ check inf ($ var x))))
8590 (cond ((name-primitive x)
8591 (set! n-possible (+ 1 n-possible))
8592 (match (check-test inf)
8595 (set! n-err (+ 1 n-err))
8596 (set! n-prim (+ 1 n-prim))
8597 `(,(symbol-append "CHECK-" (pname x))
8599 ',(string->symbol "ERROR")))
8600 (_ (set! n-prim (+ 1 n-prim))
8601 `(,(symbol-append "CHECK-" (pname x))
8603 ((name-unbound? x) `(check-bound ,(pname x)))
8605 (if (check-test inf)
8607 (set! n-clash (+ 1 n-clash))
8608 `(,(string->symbol "CLASH")
8613 ($ type _ ($ check inf (and m ($ lam x e1)))))
8614 (set! n-possible (+ 1 n-possible))
8615 (match (check-test inf)
8618 (set! n-err (+ 1 n-err))
8619 (set! n-lam (+ 1 n-lam))
8620 `(,(string->symbol "CHECK-lambda")
8621 (,(tree-index z) ',(string->symbol "ERROR"))
8624 (_ (set! n-lam (+ 1 n-lam))
8625 `(,(string->symbol "CHECK-lambda")
8632 ($ check inf (and m ($ vlam x rest e1)))))
8633 (set! n-possible (+ 1 n-possible))
8634 (match (check-test inf)
8637 (set! n-err (+ 1 n-err))
8638 (set! n-lam (+ 1 n-lam))
8639 `(,(string->symbol "CHECK-lambda")
8640 (,(tree-index z) ',(string->symbol "ERROR"))
8641 ,(append (map pname x) (pname rest))
8643 (_ (set! n-lam (+ 1 n-lam))
8644 `(,(string->symbol "CHECK-lambda")
8646 ,(append (map pname x) (pname rest))
8649 ($ type _ ($ check inf (and m ($ app e1 args)))))
8650 (set! n-possible (+ 1 n-possible))
8651 (match (check-test inf)
8654 (set! n-err (+ 1 n-err))
8655 (set! n-app (+ 1 n-app))
8656 `(,(string->symbol "CHECK-ap")
8657 (,(tree-index z) ',(string->symbol "ERROR"))
8659 ,@(map pexpr args)))
8660 (_ (set! n-app (+ 1 n-app))
8661 (let ((p1 (pexpr e1)))
8662 `(,(string->symbol "CHECK-ap")
8665 ,@(map pexpr args))))))
8667 ($ type _ ($ check inf (and m ($ field x e1)))))
8668 (set! n-possible (+ 1 n-possible))
8669 (match (check-test inf)
8672 (set! n-err (+ 1 n-err))
8673 (set! n-field (+ 1 n-field))
8674 `(,(string->symbol "CHECK-field")
8675 (,(tree-index z) ',(string->symbol "ERROR"))
8678 (_ (set! n-field (+ 1 n-field))
8679 `(,(string->symbol "CHECK-field")
8686 ($ check inf (and m ($ cast (x . _) e1)))))
8687 (set! n-possible (+ 1 n-possible))
8688 (match (check-test inf)
8690 (_ (set! n-cast (+ 1 n-cast))
8691 `(,(string->symbol "CHECK-:")
8698 ($ check inf (and m ($ match e1 clauses)))))
8699 (set! n-possible (+ 1 n-possible))
8700 (match (check-test inf)
8702 (inx (let* ((pclause
8704 (($ mclause p exp fail)
8709 `(,(ppat p) ,@(pexpr exp))))))
8711 (if (eq? 'inexhaust inx)
8713 (set! n-inexhaust (+ 1 n-inexhaust))
8714 `(,(string->symbol "CHECK-match")
8716 ,(string->symbol "INEXHAUST"))
8718 ,@(maplr pclause clauses)))
8720 (set! n-match (+ 1 n-match))
8721 `(,(string->symbol "CHECK-match")
8724 ,@(maplr pclause clauses)))))))))))))
8725 (define tree-index-list '())
8726 (define reinit-output!
8727 (lambda () (set! tree-index-list '())))
8730 (match (assq syntax tree-index-list)
8732 (let ((n (length tree-index-list)))
8733 (set! tree-index-list
8734 (cons (cons syntax n) tree-index-list))
8737 (define tree-unindex
8739 (let ((max (length tree-index-list)))
8741 (use-error "Invalid CHECK number ~a" n))
8742 (car (list-ref tree-index-list (- (- max 1) n))))))
8747 (for-each pretty-print (exp-cause def)))
8754 (for-each pretty-print (exp-cause def)))
8761 (exp-cause (find-global dname)))))
8764 (let ((sum (lambda (exps)
8765 (foldr (lambda (x y) (append (exp-cause x) y))
8769 (let ((nonlocal (map tree-index (check-sources inf))))
8770 (if (type-check1? inf)
8771 (cons (check-local-sources inf) nonlocal)
8774 ((and z ($ type ty ($ check inf ($ var x))))
8775 (if (name-primitive x)
8776 (if (type-check? inf)
8777 (list `((,(symbol-append 'check- (pname x))
8781 (if (type-check1? inf)
8782 (list `((clash ,(pname x) ,(tree-index z)) ,@(src inf)))
8784 ((and z ($ type ty ($ check inf ($ lam x e1))))
8786 (if (type-check? inf)
8787 (list `((check-lambda ,(tree-index z) ,(map pname x) ...)
8792 ($ type ty ($ check inf ($ vlam x rest e1))))
8794 (if (type-check? inf)
8795 (list `((check-lambda
8797 ,(append (map pname x) (pname rest))
8802 ((and z ($ type _ ($ check inf ($ app e1 args))))
8804 (if (type-check? inf)
8805 (list `((check-ap ,(tree-index z)) ,@(src inf)))
8809 ((and z ($ type _ ($ check inf ($ field x e1))))
8811 (if (type-check? inf)
8812 (list `((check-field ,(tree-index z) ,x ...)
8817 ($ type _ ($ check inf ($ cast (x . _) e1))))
8819 (if (type-check? inf)
8820 (list `((check-: ,(tree-index z) ,x ...) ,@(src inf)))
8826 ($ check inf (and m ($ match e1 clauses)))))
8828 (if (type-check? inf)
8829 (list `((check-match ,(tree-index z) ...) ,@(src inf)))
8832 (($ define _ e) (exp-cause e))
8833 ((? defstruct?) '())
8835 (($ app e1 args) (sum (cons e1 args)))
8836 (($ match exp clauses)
8837 (foldr (lambda (x y)
8839 (match x (($ mclause _ e _) (exp-cause e)))
8844 (($ and exps) (sum exps))
8845 (($ begin exps) (sum exps))
8847 (($ if test then els)
8852 (($ let bindings body)
8853 (foldr (lambda (x y)
8854 (append (match x (($ bind _ e) (exp-cause e))) y))
8857 (($ let* bindings body)
8858 (foldr (lambda (x y)
8859 (append (match x (($ bind _ e) (exp-cause e))) y))
8862 (($ letr bindings body)
8863 (foldr (lambda (x y)
8864 (append (match x (($ bind _ e) (exp-cause e))) y))
8867 (($ body defs exps) (sum (append defs exps)))
8868 (($ or exps) (sum exps))
8869 (($ delay e) (exp-cause e))
8870 (($ set! var body) (exp-cause body))
8871 (($ record bindings)
8872 (foldr (lambda (x y)
8873 (append (match x (($ bind _ e) (exp-cause e))) y))
8876 (($ type _ exp) (exp-cause exp)))))
8877 (define display-type tidy)
8881 (for-each globaldef tree)
8885 (match (lookup? global-env x)
8886 (#f (use-error "~a is not defined" x))
8888 `(,x : ,(display-type (name-ty ty)))))))
8890 (let* ((ty (check-type (tree-unindex n)))
8891 (type (display-type ty)))
8892 (pretty-print `(,n : ,type))))
8894 "arguments must be identifiers or CHECK numbers")))
8899 (for-each localdef tree)
8901 (lambda (x) (localdef (find-global x)))
8905 (let ((d (ormap (match-lambda
8906 ((and d ($ define x _))
8907 (and (eq? name (name-name x)) d))
8910 (unless d (use-error "~a is not defined" name))
8916 (let ((type (display-type (name-ty x))))
8917 (pretty-print `(,(pname x) : ,type))))
8920 (lambda (e) (pretty-print (expdef e))))
8922 (let* ((show (lambda (x)
8923 `(,(pname x) : ,(display-type (name-ty x)))))
8924 (pbind (match-lambda
8925 (($ bind x e) `(,(show x) ,(expdef e))))))
8928 (if (or (not x) (and (name? x) (not (name-name x))))
8930 `(define ,(show x) ,(expdef e))))
8931 ((? defstruct? d) (pdef d))
8932 ((? datatype? d) (pdef d))
8933 (($ and exps) `(and ,@(maplr expdef exps)))
8935 `(,(expdef fun) ,@(maplr expdef args)))
8936 (($ begin exps) `(begin ,@(maplr expdef exps)))
8937 (($ const c _) (pconst c))
8938 (($ if test then els)
8939 `(if ,(expdef test) ,(expdef then) ,(expdef els)))
8940 (($ lam params body)
8941 `(lambda ,(map show params) ,@(expdef body)))
8942 (($ vlam params rest body)
8943 `(lambda ,(append (map show params) (show rest))
8945 (($ let bindings body)
8946 `(let ,(map pbind bindings) ,@(expdef body)))
8947 (($ let* bindings body)
8948 `(let* ,(map pbind bindings) ,@(expdef body)))
8949 (($ letr bindings body)
8950 `(letrec ,(map pbind bindings) ,@(expdef body)))
8952 (let ((pdefs (maplr expdef defs)))
8953 (append pdefs (maplr expdef exps))))
8954 (($ record bindings)
8955 `(record ,@(maplr pbind bindings)))
8956 (($ field x e) `(field ,x ,(expdef e)))
8957 (($ cast (ty . _) e) `(: ,ty ,(expdef e)))
8958 (($ or exps) `(or ,@(maplr expdef exps)))
8959 (($ delay e) `(delay ,(expdef e)))
8961 `(set! ,(pname x) ,(expdef body)))
8962 (($ var x) (pname x))
8963 (($ match e1 clauses)
8966 (($ mclause p exp fail)
8968 `(,(expdef p) (=> ,(pname fail)) ,@(expdef exp))
8969 `(,(expdef p) ,@(expdef exp))))))
8971 `(match ,p1 ,@(maplr pclause clauses))))
8972 (($ pconst x _) (pconst x))
8973 (($ pvar x) (show x))
8976 (($ pnot pat) `(not ,(expdef pat)))
8977 (($ pand pats) `(and ,@(maplr expdef pats)))
8985 (match (cons (pname tag) args)
8986 (('pair? x y) (cons (expdef x) (expdef y)))
8987 (('box? x) (box (expdef x)))
8988 (('vector? . x) (list->vector (maplr expdef x)))
8990 `($ ,(strip-? tg) ,@(maplr expdef args)))))
8991 (($ type _ exp) (expdef exp))
8992 (($ check _ exp) (expdef exp)))))
8995 (($ type ty ($ check inf ($ var x))) ty)
8996 (($ type ty ($ check inf ($ lam x e1))) ty)
8997 (($ type ty ($ check inf ($ vlam x rest e1))) ty)
8998 (($ type _ ($ check inf ($ app e1 args)))
9000 (($ type _ ($ check inf ($ field x e1)))
9002 (($ type _ ($ check inf ($ cast (x . _) e1)))
9004 (($ type _ ($ check inf ($ match e1 clauses)))
9007 (define global-env empty-env)
9010 (define benchmarking #f)
9011 (define cons-mutators '(set-car! set-cdr!))
9017 (pretty-maximum-lines #f))
9018 (let ((output (apply do-soft args)))
9021 "Typed program written to file ~a~%"
9026 ((optimize-level 3))
9028 (printf "Reloading slow CHECKs...~%")
9029 (load (string-append
9030 installation-directory
9032 (set! benchmarking #f))
9037 ((optimize-level 3))
9043 "No benchmarking mode in this version"))
9044 (printf "Reloading fast CHECKs...~%")
9045 (load (string-append
9046 installation-directory
9048 (set! benchmarking #t))
9055 (pretty-maximum-lines #f))
9056 (let ((output (apply do-soft args)))
9058 (use-error "Output file name required to run"))
9061 "Typed program written to file ~a, executing ...~%"
9067 "Typed program written to file ~a, not executing (unbound refs)~%"
9071 ((input (? string? output))
9072 (when (strip-suffix output)
9074 "output file name cannot end in .ss or .scm"))
9075 (cond ((string? input)
9076 (soft-files (list input) output)
9078 ((and (list? input) (andmap string? input))
9079 (soft-files input output)
9081 (else (soft-def input output) output)))
9083 (cond ((string? input) (soft-files (list input) #f) #f)
9084 ((and (list? input) (andmap string? input))
9085 (soft-files input #f)
9087 (else (soft-def input #f) #f)))
9089 (cond ((string? input)
9090 (let ((o (string-append
9091 (or (strip-suffix input) input)
9093 (soft-files (list input) o)
9095 ((and (list? input) (andmap string? input))
9096 (use-error "Output file name required"))
9097 (else (soft-def input #t) #f)))
9099 "Input must be a file name or list of file names"))))
9103 (let ((dbg (match-lambda
9105 (set! display-type ptype)
9108 (set! display-type tidy)
9110 ('verbose (set! verbose #t))
9111 ('!verbose (set! verbose #f))
9112 ('times (set! times #t))
9113 ('!times (set! times #f))
9114 ('partial (set! fullsharing #f))
9115 ('!partial (set! fullsharing #t))
9116 ('pseudo (set! pseudo pseudo-subtype))
9117 ('!pseudo (set! pseudo #f))
9118 ('populated (set! populated #t))
9119 ('!populated (set! populated #f))
9120 ('matchst (set! matchst #t))
9121 ('!matchst (set! matchst #f))
9122 ('genmatch (set! genmatch #t))
9123 ('!genmatch (set! genmatch #f))
9124 ('letonce (set! letonce #t))
9125 ('!letonce (set! letonce #f))
9126 ('global-error (set! global-error #t))
9127 ('!global-error (set! global-error #f))
9128 ('share (set! share #t))
9129 ('!share (set! share #f))
9130 ('flags (set! flags #t))
9131 ('!flags (set! flags #f))
9132 ('depths (set! dump-depths #t))
9133 ('!depths (set! dump-depths #f))
9134 ('match (set! keep-match #t))
9135 ('!match (set! keep-match #f))
9136 (x (printf "Error: unknown debug switch ~a~%" x)
9140 (printf "Current values:")
9142 (lambda (x) (printf " ~a" x))
9145 (for-each dbg args)))))
9146 (define show-controls
9148 (list (if rawmode 'raw '!raw)
9149 (if verbose 'verbose '!verbose)
9150 (if times 'times '!times)
9151 (if share 'share '!share)
9152 (if flags 'flags '!flags)
9153 (if dump-depths 'depths '!depths)
9154 (if fullsharing '!partial 'partial)
9155 (if pseudo 'pseudo '!pseudo)
9156 (if populated 'populated '!populated)
9157 (if letonce 'letonce '!letonce)
9158 (if matchst 'matchst '!matchst)
9159 (if genmatch 'genmatch '!genmatch)
9160 (if global-error 'global-error '!global-error)
9161 (if keep-match 'match '!match))))
9163 (lambda (exp output)
9167 (set! visible-time 0)
9169 ((before-parse (cpu-time))
9170 (defs (parse-def exp))
9171 (before-bind (cpu-time))
9172 ((defs env tenv unbound)
9179 (_ (warn-unbound unbound))
9180 (_ (if cons-is-mutable
9182 "Note: use of ~a, treating cons as MUTABLE~%"
9185 "Note: no use of ~a, treating cons as immutable~%"
9187 (before-improve (cpu-time))
9188 (defs (improve-defs defs))
9189 (before-typecheck (cpu-time))
9190 (_ (type-check defs))
9191 (_ (set! global-env env))
9192 (before-output (cpu-time))
9194 (_ (print-summary ""))
9195 (before-end (cpu-time)))
9198 "~a seconds parsing,~%"
9200 (* (- before-bind before-parse)
9201 clock-granularity)))
9203 "~a seconds binding,~%"
9205 (* (- before-improve before-bind)
9206 clock-granularity)))
9208 "~a seconds improving,~%"
9210 (* (- before-typecheck before-improve)
9211 clock-granularity)))
9213 "~a seconds type checking,~%"
9215 (* (- (- before-output before-typecheck)
9217 clock-granularity)))
9219 "~a seconds setting visibility,~%"
9221 (* visible-time clock-granularity)))
9223 "~a seconds writing output,~%"
9225 (* (- before-end before-output)
9226 clock-granularity)))
9228 "~a seconds in total.~%"
9230 (* (- before-end before-parse) clock-granularity)))))))
9237 (lambda (files output)
9239 (map (lambda (f) `(begin ,@(readfile f))) files)))
9240 (soft-def `(begin ,@contents) output))))
9241 (define strip-suffix
9243 (let ((n (string-length name)))
9245 (equal? ".ss" (substring name (- n 3) n))
9246 (substring name 0 (- n 3)))
9248 (equal? ".scm" (substring name (- n 4) n))
9249 (substring name 0 (- n 4)))))))
9252 (((? symbol? x) ? list? mutability)
9254 (if (andmap boolean? mutability)
9255 (deftype x mutability)
9258 "Invalid command ~a"
9259 `(st:deftype ,@args)))))
9262 (((? symbol? x) type) (defprim x type 'impure))
9263 (((? symbol? x) type (? symbol? mode))
9264 (defprim x type mode))
9266 "Invalid command ~a"
9267 `(st:defprim ,@args)))))
9271 "Commands for Soft Scheme (~a)~%"
9274 " (st: file (output)) type check file and execute~%")
9276 " (st:type (name)) print types of global defs~%")
9278 " (st:check file (output)) type check file~%")
9280 " (st:run file) execute type checked file~%")
9282 " (st:bench file) execute type checked file fast~%")
9284 " (st:ltype (name)) print types of local defs~%")
9286 " (st:cause) print cause of CHECKs~%")
9288 " (st:summary) print summary of CHECKs~%")
9290 " (st:help) prints this message~%")
9292 " (st:defprim name type (mode)) define a new primitive~%")
9294 " (st:deftype name bool ...) define a new type constructor~%")
9296 " (st:control flag ...) set internal flags~%")
9298 "For more info, see ftp://ftp.nj.nec.com/pub/wright/ssmanual/softscheme.html~%")
9300 "Copyright (c) 1993, 1994, 1995 by Andrew K. Wright under the~%")
9302 "terms of the Gnu Public License. No warranties of any kind apply.~%")))
9303 (define st:type type)
9304 (define st:ltype localtype)
9305 (define st:cause cause)
9307 (lambda () (print-summary "")))
9310 (when customization-file
9311 (load (string-append
9312 installation-directory
9313 customization-file)))
9315 (string-append home-directory "/.softschemerc")))
9316 (when (file-exists? softrc) (load softrc)))
9317 (set! global-env initial-env)