Commit | Line | Data |
---|---|---|
1b706edf LC |
1 | ; Soft Scheme -- Copyright (C) 1993, 1994 Andrew K. Wright |
2 | ; | |
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. | |
7 | ; | |
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. | |
12 | ; | |
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. | |
16 | ; | |
17 | ; Packaged as a single file for Larceny by Lars T Hansen. | |
18 | ; Modified 2000-02-15 by lth. | |
19 | ; | |
20 | ; Compilation notes. | |
21 | ; | |
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 | |
27 | ; compiling. | |
28 | ; | |
29 | ; Once compiled, this program is self-contained. | |
30 | ||
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. | |
35 | ||
36 | (define (softscheme-benchmark) | |
37 | (let ((expr `(begin ,@(readfile "ss-input.scm"))) | |
38 | (out (open-output-string))) | |
39 | (run-benchmark "softscheme" | |
40 | (lambda () | |
41 | (with-output-to-port out | |
42 | (lambda () | |
43 | (soft-def expr #f))))) | |
44 | (newline) | |
45 | (display (string-length (get-output-string out))) | |
46 | (display " characters of output written.") | |
47 | (newline))) | |
48 | ||
49 | ;;; Define defmacro, macro?, and macroexpand-1. | |
50 | ||
51 | (define *macros* '()) | |
52 | ||
53 | (define-syntax | |
54 | defmacro | |
55 | (transformer | |
56 | (lambda (exp rename compare) | |
57 | (define (arglist? x) | |
58 | (or (symbol? x) | |
59 | (null? x) | |
60 | (and (pair? x) | |
61 | (symbol? (car x)) | |
62 | (arglist? (cdr x))))) | |
63 | (if (not (and (list? exp) | |
64 | (>= (length exp) 4) | |
65 | (symbol? (cadr exp)) | |
66 | (arglist? (caddr exp)))) | |
67 | (error "Bad macro definition: " exp)) | |
68 | (let ((name (cadr exp)) | |
69 | (args (caddr exp)) | |
70 | (body (cdddr exp))) | |
71 | `(begin | |
72 | (define-syntax | |
73 | ,name | |
74 | (transformer | |
75 | (lambda (_defmacro_exp | |
76 | _defmacro_rename | |
77 | _defmacro_compare) | |
78 | (apply (lambda ,args ,@body) (cdr _defmacro_exp))))) | |
79 | (set! *macros* | |
80 | (cons (cons ',name | |
81 | (lambda (_exp) | |
82 | (apply (lambda ,args ,@body) (cdr _exp)))) | |
83 | *macros*)) | |
84 | ))))) | |
85 | ||
86 | (define (macroexpand-1 exp) | |
87 | (cond ((pair? exp) | |
88 | (let ((probe (assq (car exp) *macros*))) | |
89 | (if probe ((cdr probe) exp) exp))) | |
90 | (else exp))) | |
91 | ||
92 | (define (macro? keyword) | |
93 | (and (symbol? keyword) (assq keyword *macros*))) | |
94 | ||
95 | ;;; Other compatibility hacks | |
96 | ||
97 | (define slib:error error) | |
98 | ||
99 | (define force-output flush-output-port) | |
100 | ||
101 | (define format | |
102 | (let ((format format)) | |
103 | (lambda (port . rest) | |
104 | (if (not port) | |
105 | (let ((s (open-output-string))) | |
106 | (apply format s rest) | |
107 | (get-output-string s)) | |
108 | (apply format port rest))))) | |
109 | ||
110 | (define gentemp | |
111 | (let ((gensym gensym)) (lambda () (gensym "G")))) | |
112 | ||
113 | (define getenv | |
114 | (let ((getenv getenv)) | |
115 | (lambda (x) | |
116 | (or (getenv x) | |
117 | (if (string=? x "HOME") | |
118 | "Ertevann:Desktop folder:" | |
119 | #f))))) | |
120 | ||
121 | ;;; The rest of the file should be more or less portable. | |
122 | ||
123 | (define match-file #f) | |
124 | (define installation-directory #f) | |
125 | (define customization-file #f) | |
126 | (define fastlibrary-file #f) | |
127 | (define st:version | |
128 | "Larceny Version 0.18, April 21, 1995") | |
129 | (define match:version | |
130 | "Version 1.18, July 17, 1995") | |
131 | (define match:error | |
132 | (lambda (val . args) | |
133 | (for-each pretty-print args) | |
134 | (slib:error "no matching clause for " val))) | |
135 | (define match:andmap | |
136 | (lambda (f l) | |
137 | (if (null? l) | |
138 | (and) | |
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 | |
144 | (lambda (name) | |
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)) | |
150 | tag) | |
151 | (string->symbol | |
152 | (string-append "<" (symbol->string name) ">"))))) | |
153 | (define match:structure? | |
154 | (lambda (tag) | |
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 | |
165 | (cons 'null | |
166 | '(pair? symbol? | |
167 | boolean? | |
168 | number? | |
169 | string? | |
170 | char? | |
171 | procedure? | |
172 | vector?))) | |
173 | (define match:vector-structures '()) | |
174 | (define match:expanders | |
175 | (letrec ((genmatch | |
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 | |
182 | (car c)))) | |
183 | (p (car x)) | |
184 | (bv (cadr x)) | |
185 | (bindings (caddr x)) | |
186 | (code (gentemp)) | |
187 | (fail (and (pair? (cdr c)) | |
188 | (pair? (cadr c)) | |
189 | (eq? (caadr c) '=>) | |
190 | (symbol? (cadadr c)) | |
191 | (pair? (cdadr c)) | |
192 | (null? (cddadr c)) | |
193 | (pair? (cddr c)) | |
194 | (cadadr c))) | |
195 | (bv2 (if fail (cons fail bv) bv)) | |
196 | (body (if fail (cddr c) (cdr c)))) | |
197 | (set! blist | |
198 | (cons `(,code (lambda ,bv2 ,@body)) | |
199 | (append bindings blist))) | |
200 | (list p | |
201 | code | |
202 | bv | |
203 | (and fail (gentemp)) | |
204 | #f))) | |
205 | clauses)) | |
206 | (code (gen x | |
207 | '() | |
208 | plist | |
209 | (cdr eb-errf) | |
210 | length>= | |
211 | (gentemp)))) | |
212 | (unreachable plist match-expr) | |
213 | (inline-let | |
214 | `(let ((,length>= | |
215 | (lambda (n) (lambda (l) (>= (length l) n)))) | |
216 | ,@blist) | |
217 | ,code))))) | |
218 | (genletrec | |
219 | (lambda (pat exp body match-expr) | |
220 | (let* ((length>= (gentemp)) | |
221 | (eb-errf (error-maker match-expr)) | |
222 | (x (bound (validate-pattern pat))) | |
223 | (p (car x)) | |
224 | (bv (cadr x)) | |
225 | (bindings (caddr x)) | |
226 | (code (gentemp)) | |
227 | (plist (list (list p code bv #f #f))) | |
228 | (x (gentemp)) | |
229 | (m (gen x | |
230 | '() | |
231 | plist | |
232 | (cdr eb-errf) | |
233 | length>= | |
234 | (gentemp))) | |
235 | (gs (map (lambda (_) (gentemp)) bv))) | |
236 | (unreachable plist match-expr) | |
237 | `(letrec ((,length>= | |
238 | (lambda (n) (lambda (l) (>= (length l) n)))) | |
239 | ,@(map (lambda (v) `(,v #f)) bv) | |
240 | (,x ,exp) | |
241 | (,code | |
242 | (lambda ,gs | |
243 | ,@(map (lambda (v g) `(set! ,v ,g)) bv gs) | |
244 | ,@body)) | |
245 | ,@bindings | |
246 | ,@(car eb-errf)) | |
247 | ,m)))) | |
248 | (gendefine | |
249 | (lambda (pat exp match-expr) | |
250 | (let* ((length>= (gentemp)) | |
251 | (eb-errf (error-maker match-expr)) | |
252 | (x (bound (validate-pattern pat))) | |
253 | (p (car x)) | |
254 | (bv (cadr x)) | |
255 | (bindings (caddr x)) | |
256 | (code (gentemp)) | |
257 | (plist (list (list p code bv #f #f))) | |
258 | (x (gentemp)) | |
259 | (m (gen x | |
260 | '() | |
261 | plist | |
262 | (cdr eb-errf) | |
263 | length>= | |
264 | (gentemp))) | |
265 | (gs (map (lambda (_) (gentemp)) bv))) | |
266 | (unreachable plist match-expr) | |
267 | `(begin | |
268 | ,@(map (lambda (v) `(define ,v #f)) bv) | |
269 | ,(inline-let | |
270 | `(let ((,length>= | |
271 | (lambda (n) (lambda (l) (>= (length l) n)))) | |
272 | (,x ,exp) | |
273 | (,code | |
274 | (lambda ,gs | |
275 | ,@(map (lambda (v g) `(set! ,v ,g)) bv gs) | |
276 | (cond (#f #f)))) | |
277 | ,@bindings | |
278 | ,@(car eb-errf)) | |
279 | ,m)))))) | |
280 | (pattern-var? | |
281 | (lambda (x) | |
282 | (and (symbol? x) | |
283 | (not (dot-dot-k? x)) | |
284 | (not (memq x | |
285 | '(quasiquote | |
286 | quote | |
287 | unquote | |
288 | unquote-splicing | |
289 | ? | |
290 | _ | |
291 | $ | |
292 | = | |
293 | and | |
294 | or | |
295 | not | |
296 | set! | |
297 | get! | |
298 | ... | |
299 | ___)))))) | |
300 | (dot-dot-k? | |
301 | (lambda (s) | |
302 | (and (symbol? s) | |
303 | (if (memq s '(... ___)) | |
304 | 0 | |
305 | (let* ((s (symbol->string s)) (n (string-length s))) | |
306 | (and (<= 3 n) | |
307 | (memq (string-ref s 0) '(#\. #\_)) | |
308 | (memq (string-ref s 1) '(#\. #\_)) | |
309 | (match:andmap | |
310 | char-numeric? | |
311 | (string->list (substring s 2 n))) | |
312 | (string->number (substring s 2 n)))))))) | |
313 | (error-maker | |
314 | (lambda (match-expr) | |
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))) | |
321 | (cons `((,errf | |
322 | (lambda (,arg) | |
323 | (match:error ,arg ',match-expr)))) | |
324 | (lambda (x) `(,errf ,x))))) | |
325 | (else | |
326 | (match:syntax-err | |
327 | '(unspecified error fail match) | |
328 | "invalid value for match:error-control, legal values are"))))) | |
329 | (unreachable | |
330 | (lambda (plist match-expr) | |
331 | (for-each | |
332 | (lambda (x) | |
333 | (if (not (car (cddddr x))) | |
334 | (begin | |
335 | (display "Warning: unreachable pattern ") | |
336 | (display (car x)) | |
337 | (display " in ") | |
338 | (display match-expr) | |
339 | (newline)))) | |
340 | plist))) | |
341 | (validate-pattern | |
342 | (lambda (pattern) | |
343 | (letrec ((simple? | |
344 | (lambda (x) | |
345 | (or (string? x) | |
346 | (boolean? x) | |
347 | (char? x) | |
348 | (number? x) | |
349 | (null? x)))) | |
350 | (ordinary | |
351 | (lambda (p) | |
352 | (let ((g88 (lambda (x y) | |
353 | (cons (ordinary x) (ordinary y))))) | |
354 | (if (simple? p) | |
355 | ((lambda (p) p) p) | |
356 | (if (equal? p '_) | |
357 | ((lambda () '_)) | |
358 | (if (pattern-var? p) | |
359 | ((lambda (p) p) p) | |
360 | (if (pair? p) | |
361 | (if (equal? (car p) 'quasiquote) | |
362 | (if (and (pair? (cdr p)) | |
363 | (null? (cddr 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)) | |
368 | (null? (cddr p))) | |
369 | ((lambda (p) p) p) | |
370 | (g88 (car p) (cdr p))) | |
371 | (if (equal? (car p) '?) | |
372 | (if (and (pair? (cdr p)) | |
373 | (list? (cddr p))) | |
374 | ((lambda (pred ps) | |
375 | `(? ,pred | |
376 | ,@(map ordinary ps))) | |
377 | (cadr p) | |
378 | (cddr p)) | |
379 | (g88 (car p) (cdr p))) | |
380 | (if (equal? (car p) '=) | |
381 | (if (and (pair? (cdr p)) | |
382 | (pair? (cddr p)) | |
383 | (null? (cdddr p))) | |
384 | ((lambda (sel p) | |
385 | `(= ,sel ,(ordinary p))) | |
386 | (cadr p) | |
387 | (caddr p)) | |
388 | (g88 (car p) (cdr p))) | |
389 | (if (equal? (car p) 'and) | |
390 | (if (and (list? (cdr p)) | |
391 | (pair? (cdr p))) | |
392 | ((lambda (ps) | |
393 | `(and ,@(map ordinary | |
394 | ps))) | |
395 | (cdr p)) | |
396 | (g88 (car p) (cdr p))) | |
397 | (if (equal? (car p) 'or) | |
398 | (if (and (list? (cdr p)) | |
399 | (pair? (cdr p))) | |
400 | ((lambda (ps) | |
401 | `(or ,@(map ordinary | |
402 | ps))) | |
403 | (cdr p)) | |
404 | (g88 (car p) (cdr p))) | |
405 | (if (equal? (car p) 'not) | |
406 | (if (and (list? (cdr p)) | |
407 | (pair? (cdr p))) | |
408 | ((lambda (ps) | |
409 | `(not ,@(map ordinary | |
410 | ps))) | |
411 | (cdr p)) | |
412 | (g88 (car p) (cdr p))) | |
413 | (if (equal? (car p) '$) | |
414 | (if (and (pair? (cdr p)) | |
415 | (symbol? | |
416 | (cadr p)) | |
417 | (list? (cddr p))) | |
418 | ((lambda (r ps) | |
419 | `($ ,r | |
420 | ,@(map ordinary | |
421 | ps))) | |
422 | (cadr p) | |
423 | (cddr p)) | |
424 | (g88 (car p) (cdr p))) | |
425 | (if (equal? | |
426 | (car p) | |
427 | 'set!) | |
428 | (if (and (pair? (cdr p)) | |
429 | (pattern-var? | |
430 | (cadr p)) | |
431 | (null? (cddr p))) | |
432 | ((lambda (p) p) p) | |
433 | (g88 (car p) | |
434 | (cdr p))) | |
435 | (if (equal? | |
436 | (car p) | |
437 | 'get!) | |
438 | (if (and (pair? (cdr p)) | |
439 | (pattern-var? | |
440 | (cadr p)) | |
441 | (null? (cddr p))) | |
442 | ((lambda (p) p) p) | |
443 | (g88 (car p) | |
444 | (cdr p))) | |
445 | (if (equal? | |
446 | (car p) | |
447 | 'unquote) | |
448 | (g88 (car p) | |
449 | (cdr p)) | |
450 | (if (equal? | |
451 | (car p) | |
452 | 'unquote-splicing) | |
453 | (g88 (car p) | |
454 | (cdr p)) | |
455 | (if (and (pair? (cdr p)) | |
456 | (dot-dot-k? | |
457 | (cadr p)) | |
458 | (null? (cddr p))) | |
459 | ((lambda (p | |
460 | ddk) | |
461 | `(,(ordinary | |
462 | p) | |
463 | ,ddk)) | |
464 | (car p) | |
465 | (cadr p)) | |
466 | (g88 (car p) | |
467 | (cdr p))))))))))))))) | |
468 | (if (vector? p) | |
469 | ((lambda (p) | |
470 | (let* ((pl (vector->list p)) | |
471 | (rpl (reverse pl))) | |
472 | (apply vector | |
473 | (if (and (not (null? rpl)) | |
474 | (dot-dot-k? | |
475 | (car rpl))) | |
476 | (reverse | |
477 | (cons (car rpl) | |
478 | (map ordinary | |
479 | (cdr rpl)))) | |
480 | (map ordinary pl))))) | |
481 | p) | |
482 | ((lambda () | |
483 | (match:syntax-err | |
484 | pattern | |
485 | "syntax error in pattern"))))))))))) | |
486 | (quasi (lambda (p) | |
487 | (let ((g109 (lambda (x y) | |
488 | (cons (quasi x) (quasi y))))) | |
489 | (if (simple? p) | |
490 | ((lambda (p) p) p) | |
491 | (if (symbol? p) | |
492 | ((lambda (p) `',p) p) | |
493 | (if (pair? p) | |
494 | (if (equal? (car p) 'unquote) | |
495 | (if (and (pair? (cdr p)) | |
496 | (null? (cddr p))) | |
497 | ((lambda (p) (ordinary p)) | |
498 | (cadr p)) | |
499 | (g109 (car p) (cdr p))) | |
500 | (if (and (pair? (car p)) | |
501 | (equal? | |
502 | (caar p) | |
503 | 'unquote-splicing) | |
504 | (pair? (cdar p)) | |
505 | (null? (cddar p))) | |
506 | (if (null? (cdr p)) | |
507 | ((lambda (p) (ordinary p)) | |
508 | (cadar p)) | |
509 | ((lambda (p y) | |
510 | (append | |
511 | (ordlist p) | |
512 | (quasi y))) | |
513 | (cadar p) | |
514 | (cdr p))) | |
515 | (if (and (pair? (cdr p)) | |
516 | (dot-dot-k? (cadr p)) | |
517 | (null? (cddr p))) | |
518 | ((lambda (p ddk) | |
519 | `(,(quasi p) ,ddk)) | |
520 | (car p) | |
521 | (cadr p)) | |
522 | (g109 (car p) (cdr p))))) | |
523 | (if (vector? p) | |
524 | ((lambda (p) | |
525 | (let* ((pl (vector->list p)) | |
526 | (rpl (reverse pl))) | |
527 | (apply vector | |
528 | (if (dot-dot-k? | |
529 | (car rpl)) | |
530 | (reverse | |
531 | (cons (car rpl) | |
532 | (map quasi | |
533 | (cdr rpl)))) | |
534 | (map ordinary pl))))) | |
535 | p) | |
536 | ((lambda () | |
537 | (match:syntax-err | |
538 | pattern | |
539 | "syntax error in pattern")))))))))) | |
540 | (ordlist | |
541 | (lambda (p) | |
542 | (cond ((null? p) '()) | |
543 | ((pair? p) | |
544 | (cons (ordinary (car p)) (ordlist (cdr p)))) | |
545 | (else | |
546 | (match:syntax-err | |
547 | pattern | |
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)) | |
554 | ((symbol? p) | |
555 | (if (memq p a) | |
556 | (match:syntax-err | |
557 | pattern | |
558 | "duplicate variable in pattern")) | |
559 | (k p (cons p a))) | |
560 | ((and (pair? p) | |
561 | (eq? 'quote (car p))) | |
562 | (k p a)) | |
563 | ((and (pair? p) (eq? '? (car p))) | |
564 | (cond ((not (null? (cddr p))) | |
565 | (bound `(and (? ,(cadr p)) | |
566 | ,@(cddr p)) | |
567 | a | |
568 | k)) | |
569 | ((or (not (symbol? | |
570 | (cadr p))) | |
571 | (memq (cadr p) a)) | |
572 | (let ((g (gentemp))) | |
573 | (set! pred-bodies | |
574 | (cons `(,g ,(cadr p)) | |
575 | pred-bodies)) | |
576 | (k `(? ,g) a))) | |
577 | (else (k p a)))) | |
578 | ((and (pair? p) (eq? '= (car p))) | |
579 | (cond ((or (not (symbol? | |
580 | (cadr p))) | |
581 | (memq (cadr p) a)) | |
582 | (let ((g (gentemp))) | |
583 | (set! pred-bodies | |
584 | (cons `(,g ,(cadr p)) | |
585 | pred-bodies)) | |
586 | (bound `(= ,g ,(caddr p)) | |
587 | a | |
588 | k))) | |
589 | (else | |
590 | (bound (caddr p) | |
591 | a | |
592 | (lambda (p2 a) | |
593 | (k `(= ,(cadr p) | |
594 | ,p2) | |
595 | a)))))) | |
596 | ((and (pair? p) (eq? 'and (car p))) | |
597 | (bound* | |
598 | (cdr p) | |
599 | a | |
600 | (lambda (p a) | |
601 | (k `(and ,@p) a)))) | |
602 | ((and (pair? p) (eq? 'or (car p))) | |
603 | (bound (cadr p) | |
604 | a | |
605 | (lambda (first-p first-a) | |
606 | (let or* ((plist (cddr p)) | |
607 | (k (lambda (plist) | |
608 | (k `(or ,first-p | |
609 | ,@plist) | |
610 | first-a)))) | |
611 | (if (null? plist) | |
612 | (k plist) | |
613 | (bound (car plist) | |
614 | a | |
615 | (lambda (car-p | |
616 | car-a) | |
617 | (if (not (permutation | |
618 | car-a | |
619 | first-a)) | |
620 | (match:syntax-err | |
621 | pattern | |
622 | "variables of or-pattern differ in")) | |
623 | (or* (cdr plist) | |
624 | (lambda (cdr-p) | |
625 | (k (cons car-p | |
626 | cdr-p))))))))))) | |
627 | ((and (pair? p) (eq? 'not (car p))) | |
628 | (cond ((not (null? (cddr p))) | |
629 | (bound `(not (or ,@(cdr p))) | |
630 | a | |
631 | k)) | |
632 | (else | |
633 | (bound (cadr p) | |
634 | a | |
635 | (lambda (p2 a2) | |
636 | (if (not (permutation | |
637 | a | |
638 | a2)) | |
639 | (match:syntax-err | |
640 | p | |
641 | "no variables allowed in")) | |
642 | (k `(not ,p2) | |
643 | a)))))) | |
644 | ((and (pair? p) | |
645 | (pair? (cdr p)) | |
646 | (dot-dot-k? (cadr p))) | |
647 | (bound (car p) | |
648 | a | |
649 | (lambda (q b) | |
650 | (let ((bvars (find-prefix | |
651 | b | |
652 | a))) | |
653 | (k `(,q | |
654 | ,(cadr p) | |
655 | ,bvars | |
656 | ,(gentemp) | |
657 | ,(gentemp) | |
658 | ,(map (lambda (_) | |
659 | (gentemp)) | |
660 | bvars)) | |
661 | b))))) | |
662 | ((and (pair? p) (eq? '$ (car p))) | |
663 | (bound* | |
664 | (cddr p) | |
665 | a | |
666 | (lambda (p1 a) | |
667 | (k `($ ,(cadr p) ,@p1) a)))) | |
668 | ((and (pair? p) | |
669 | (eq? 'set! (car p))) | |
670 | (if (memq (cadr p) a) | |
671 | (k p a) | |
672 | (k p (cons (cadr p) a)))) | |
673 | ((and (pair? p) | |
674 | (eq? 'get! (car p))) | |
675 | (if (memq (cadr p) a) | |
676 | (k p a) | |
677 | (k p (cons (cadr p) a)))) | |
678 | ((pair? p) | |
679 | (bound (car p) | |
680 | a | |
681 | (lambda (car-p a) | |
682 | (bound (cdr p) | |
683 | a | |
684 | (lambda (cdr-p a) | |
685 | (k (cons car-p | |
686 | cdr-p) | |
687 | a)))))) | |
688 | ((vector? p) | |
689 | (boundv | |
690 | (vector->list p) | |
691 | a | |
692 | (lambda (pl a) | |
693 | (k (list->vector pl) a)))) | |
694 | (else (k p a))))) | |
695 | (boundv | |
696 | (lambda (plist a k) | |
697 | (let ((g115 (lambda () (k plist a)))) | |
698 | (if (pair? plist) | |
699 | (if (and (pair? (cdr plist)) | |
700 | (dot-dot-k? (cadr plist)) | |
701 | (null? (cddr plist))) | |
702 | ((lambda () (bound plist a k))) | |
703 | (if (null? plist) | |
704 | (g115) | |
705 | ((lambda (x y) | |
706 | (bound x | |
707 | a | |
708 | (lambda (car-p a) | |
709 | (boundv | |
710 | y | |
711 | a | |
712 | (lambda (cdr-p a) | |
713 | (k (cons car-p cdr-p) | |
714 | a)))))) | |
715 | (car plist) | |
716 | (cdr plist)))) | |
717 | (if (null? plist) | |
718 | (g115) | |
719 | (match:error plist)))))) | |
720 | (bound* | |
721 | (lambda (plist a k) | |
722 | (if (null? plist) | |
723 | (k plist a) | |
724 | (bound (car plist) | |
725 | a | |
726 | (lambda (car-p a) | |
727 | (bound* | |
728 | (cdr plist) | |
729 | a | |
730 | (lambda (cdr-p a) | |
731 | (k (cons car-p cdr-p) a)))))))) | |
732 | (find-prefix | |
733 | (lambda (b a) | |
734 | (if (eq? b a) | |
735 | '() | |
736 | (cons (car b) (find-prefix (cdr b) a))))) | |
737 | (permutation | |
738 | (lambda (p1 p2) | |
739 | (and (= (length p1) (length p2)) | |
740 | (match:andmap | |
741 | (lambda (x1) (memq x1 p2)) | |
742 | p1))))) | |
743 | (bound pattern | |
744 | '() | |
745 | (lambda (p a) | |
746 | (list p (reverse a) pred-bodies)))))) | |
747 | (inline-let | |
748 | (lambda (let-exp) | |
749 | (letrec ((occ (lambda (x e) | |
750 | (let loop ((e e)) | |
751 | (cond ((pair? e) | |
752 | (+ (loop (car e)) (loop (cdr e)))) | |
753 | ((eq? x e) 1) | |
754 | (else 0))))) | |
755 | (subst (lambda (e old new) | |
756 | (let loop ((e e)) | |
757 | (cond ((pair? e) | |
758 | (cons (loop (car e)) (loop (cdr e)))) | |
759 | ((eq? old e) new) | |
760 | (else e))))) | |
761 | (const? | |
762 | (lambda (sexp) | |
763 | (or (symbol? sexp) | |
764 | (boolean? sexp) | |
765 | (string? sexp) | |
766 | (char? sexp) | |
767 | (number? sexp) | |
768 | (null? sexp) | |
769 | (and (pair? sexp) | |
770 | (eq? (car sexp) 'quote) | |
771 | (pair? (cdr sexp)) | |
772 | (symbol? (cadr sexp)) | |
773 | (null? (cddr sexp)))))) | |
774 | (isval? | |
775 | (lambda (sexp) | |
776 | (or (const? sexp) | |
777 | (and (pair? sexp) | |
778 | (memq (car sexp) | |
779 | '(lambda quote | |
780 | match-lambda | |
781 | match-lambda*)))))) | |
782 | (small? | |
783 | (lambda (sexp) | |
784 | (or (const? sexp) | |
785 | (and (pair? sexp) | |
786 | (eq? (car sexp) 'lambda) | |
787 | (pair? (cdr sexp)) | |
788 | (pair? (cddr sexp)) | |
789 | (const? (caddr sexp)) | |
790 | (null? (cdddr sexp))))))) | |
791 | (let loop ((b (cadr let-exp)) | |
792 | (new-b '()) | |
793 | (e (caddr let-exp))) | |
794 | (cond ((null? b) | |
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)))) | |
800 | (loop (cdr b) | |
801 | new-b | |
802 | (subst e x (cadr (car b))))) | |
803 | (else | |
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) | |
807 | (if (null? plist) | |
808 | (erract x) | |
809 | (let* ((v '()) | |
810 | (val (lambda (x) (cdr (assq x v)))) | |
811 | (fail (lambda (sf) | |
812 | (gen x sf (cdr plist) erract length>= eta))) | |
813 | (success | |
814 | (lambda (sf) | |
815 | (set-car! (cddddr (car plist)) #t) | |
816 | (let* ((code (cadr (car plist))) | |
817 | (bv (caddr (car plist))) | |
818 | (fail-sym (cadddr (car plist)))) | |
819 | (if fail-sym | |
820 | (let ((ap `(,code | |
821 | ,fail-sym | |
822 | ,@(map val bv)))) | |
823 | `(call-with-current-continuation | |
824 | (lambda (,fail-sym) | |
825 | (let ((,fail-sym | |
826 | (lambda () | |
827 | (,fail-sym ,(fail sf))))) | |
828 | ,ap)))) | |
829 | `(,code ,@(map val bv))))))) | |
830 | (let next ((p (caar plist)) | |
831 | (e x) | |
832 | (sf sf) | |
833 | (kf fail) | |
834 | (ks success)) | |
835 | (cond ((eq? '_ p) (ks sf)) | |
836 | ((symbol? p) | |
837 | (set! v (cons (cons p e) v)) | |
838 | (ks sf)) | |
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)) | |
854 | (if (null? p) | |
855 | (ks sf) | |
856 | (next (car p) | |
857 | e | |
858 | sf | |
859 | kf | |
860 | (lambda (sf) (loop (cdr p) sf)))))) | |
861 | ((and (pair? p) (eq? 'or (car p))) | |
862 | (let ((or-v v)) | |
863 | (let loop ((p (cdr p)) (sf sf)) | |
864 | (if (null? p) | |
865 | (kf sf) | |
866 | (begin | |
867 | (set! v or-v) | |
868 | (next (car p) | |
869 | e | |
870 | sf | |
871 | (lambda (sf) (loop (cdr p) sf)) | |
872 | ks)))))) | |
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)) | |
877 | (fields (cdr p)) | |
878 | (rlen (length fields)) | |
879 | (tst `(,(symbol-append tag '?) ,e))) | |
880 | (emit tst | |
881 | sf | |
882 | kf | |
883 | (let rloop ((n 1)) | |
884 | (lambda (sf) | |
885 | (if (= n rlen) | |
886 | (ks sf) | |
887 | (next (list-ref fields n) | |
888 | `(,(symbol-append tag '- n) | |
889 | ,e) | |
890 | sf | |
891 | kf | |
892 | (rloop (+ 1 n))))))))) | |
893 | ((and (pair? p) (eq? 'set! (car p))) | |
894 | (set! v (cons (cons (cadr p) (setter e p)) v)) | |
895 | (ks sf)) | |
896 | ((and (pair? p) (eq? 'get! (car p))) | |
897 | (set! v (cons (cons (cadr p) (getter e p)) v)) | |
898 | (ks sf)) | |
899 | ((and (pair? p) | |
900 | (pair? (cdr p)) | |
901 | (dot-dot-k? (cadr p))) | |
902 | (emit `(list? ,e) | |
903 | sf | |
904 | kf | |
905 | (lambda (sf) | |
906 | (let* ((k (dot-dot-k? (cadr p))) | |
907 | (ks (lambda (sf) | |
908 | (let ((bound (list-ref | |
909 | p | |
910 | 2))) | |
911 | (cond ((eq? (car p) '_) | |
912 | (ks sf)) | |
913 | ((null? bound) | |
914 | (let* ((ptst (next (car p) | |
915 | eta | |
916 | sf | |
917 | (lambda (sf) | |
918 | #f) | |
919 | (lambda (sf) | |
920 | #t))) | |
921 | (tst (if (and (pair? ptst) | |
922 | (symbol? | |
923 | (car ptst)) | |
924 | (pair? (cdr ptst)) | |
925 | (eq? eta | |
926 | (cadr ptst)) | |
927 | (null? (cddr ptst))) | |
928 | (car ptst) | |
929 | `(lambda (,eta) | |
930 | ,ptst)))) | |
931 | (assm `(match:andmap | |
932 | ,tst | |
933 | ,e) | |
934 | (kf sf) | |
935 | (ks sf)))) | |
936 | ((and (symbol? | |
937 | (car p)) | |
938 | (equal? | |
939 | (list (car p)) | |
940 | bound)) | |
941 | (next (car p) | |
942 | e | |
943 | sf | |
944 | kf | |
945 | ks)) | |
946 | (else | |
947 | (let* ((gloop (list-ref | |
948 | p | |
949 | 3)) | |
950 | (ge (list-ref | |
951 | p | |
952 | 4)) | |
953 | (fresh (list-ref | |
954 | p | |
955 | 5)) | |
956 | (p1 (next (car p) | |
957 | `(car ,ge) | |
958 | sf | |
959 | kf | |
960 | (lambda (sf) | |
961 | `(,gloop | |
962 | (cdr ,ge) | |
963 | ,@(map (lambda (b | |
964 | f) | |
965 | `(cons ,(val b) | |
966 | ,f)) | |
967 | bound | |
968 | fresh)))))) | |
969 | (set! v | |
970 | (append | |
971 | (map cons | |
972 | bound | |
973 | (map (lambda (x) | |
974 | `(reverse | |
975 | ,x)) | |
976 | fresh)) | |
977 | v)) | |
978 | `(let ,gloop | |
979 | ((,ge ,e) | |
980 | ,@(map (lambda (x) | |
981 | `(,x | |
982 | '())) | |
983 | fresh)) | |
984 | (if (null? ,ge) | |
985 | ,(ks sf) | |
986 | ,p1))))))))) | |
987 | (case k | |
988 | ((0) (ks sf)) | |
989 | ((1) (emit `(pair? ,e) sf kf ks)) | |
990 | (else | |
991 | (emit `((,length>= ,k) ,e) | |
992 | sf | |
993 | kf | |
994 | ks))))))) | |
995 | ((pair? p) | |
996 | (emit `(pair? ,e) | |
997 | sf | |
998 | kf | |
999 | (lambda (sf) | |
1000 | (next (car p) | |
1001 | (add-a e) | |
1002 | sf | |
1003 | kf | |
1004 | (lambda (sf) | |
1005 | (next (cdr p) | |
1006 | (add-d e) | |
1007 | sf | |
1008 | kf | |
1009 | ks)))))) | |
1010 | ((and (vector? p) | |
1011 | (>= (vector-length p) 6) | |
1012 | (dot-dot-k? | |
1013 | (vector-ref p (- (vector-length p) 5)))) | |
1014 | (let* ((vlen (- (vector-length p) 6)) | |
1015 | (k (dot-dot-k? | |
1016 | (vector-ref p (+ vlen 1)))) | |
1017 | (minlen (+ vlen k)) | |
1018 | (bound (vector-ref p (+ vlen 2)))) | |
1019 | (emit `(vector? ,e) | |
1020 | sf | |
1021 | kf | |
1022 | (lambda (sf) | |
1023 | (assm `(>= (vector-length ,e) ,minlen) | |
1024 | (kf sf) | |
1025 | ((let vloop ((n 0)) | |
1026 | (lambda (sf) | |
1027 | (cond ((not (= n vlen)) | |
1028 | (next (vector-ref | |
1029 | p | |
1030 | n) | |
1031 | `(vector-ref | |
1032 | ,e | |
1033 | ,n) | |
1034 | sf | |
1035 | kf | |
1036 | (vloop (+ 1 | |
1037 | n)))) | |
1038 | ((eq? (vector-ref | |
1039 | p | |
1040 | vlen) | |
1041 | '_) | |
1042 | (ks sf)) | |
1043 | (else | |
1044 | (let* ((gloop (vector-ref | |
1045 | p | |
1046 | (+ vlen | |
1047 | 3))) | |
1048 | (ind (vector-ref | |
1049 | p | |
1050 | (+ vlen | |
1051 | 4))) | |
1052 | (fresh (vector-ref | |
1053 | p | |
1054 | (+ vlen | |
1055 | 5))) | |
1056 | (p1 (next (vector-ref | |
1057 | p | |
1058 | vlen) | |
1059 | `(vector-ref | |
1060 | ,e | |
1061 | ,ind) | |
1062 | sf | |
1063 | kf | |
1064 | (lambda (sf) | |
1065 | `(,gloop | |
1066 | (- ,ind | |
1067 | 1) | |
1068 | ,@(map (lambda (b | |
1069 | f) | |
1070 | `(cons ,(val b) | |
1071 | ,f)) | |
1072 | bound | |
1073 | fresh)))))) | |
1074 | (set! v | |
1075 | (append | |
1076 | (map cons | |
1077 | bound | |
1078 | fresh) | |
1079 | v)) | |
1080 | `(let ,gloop | |
1081 | ((,ind | |
1082 | (- (vector-length | |
1083 | ,e) | |
1084 | 1)) | |
1085 | ,@(map (lambda (x) | |
1086 | `(,x | |
1087 | '())) | |
1088 | fresh)) | |
1089 | (if (> ,minlen | |
1090 | ,ind) | |
1091 | ,(ks sf) | |
1092 | ,p1))))))) | |
1093 | sf)))))) | |
1094 | ((vector? p) | |
1095 | (let ((vlen (vector-length p))) | |
1096 | (emit `(vector? ,e) | |
1097 | sf | |
1098 | kf | |
1099 | (lambda (sf) | |
1100 | (emit `(equal? | |
1101 | (vector-length ,e) | |
1102 | ,vlen) | |
1103 | sf | |
1104 | kf | |
1105 | (let vloop ((n 0)) | |
1106 | (lambda (sf) | |
1107 | (if (= n vlen) | |
1108 | (ks sf) | |
1109 | (next (vector-ref p n) | |
1110 | `(vector-ref ,e ,n) | |
1111 | sf | |
1112 | kf | |
1113 | (vloop (+ 1 | |
1114 | n))))))))))) | |
1115 | (else | |
1116 | (display "FATAL ERROR IN PATTERN MATCHER") | |
1117 | (newline) | |
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)) | |
1122 | (else | |
1123 | (let* ((e (cadr tst)) | |
1124 | (implied | |
1125 | (cond ((eq? (car tst) 'equal?) | |
1126 | (let ((p (caddr tst))) | |
1127 | (cond ((string? p) `((string? ,e))) | |
1128 | ((boolean? p) | |
1129 | `((boolean? ,e))) | |
1130 | ((char? p) `((char? ,e))) | |
1131 | ((number? p) `((number? ,e))) | |
1132 | ((and (pair? p) | |
1133 | (eq? 'quote (car p))) | |
1134 | `((symbol? ,e))) | |
1135 | (else '())))) | |
1136 | ((eq? (car tst) 'null?) `((list? ,e))) | |
1137 | ((vec-structure? tst) `((vector? ,e))) | |
1138 | (else '()))) | |
1139 | (not-imp | |
1140 | (case (car tst) | |
1141 | ((list?) `((not (null? ,e)))) | |
1142 | (else '()))) | |
1143 | (s (ks (cons tst (append implied sf)))) | |
1144 | (k (kf (cons `(not ,tst) | |
1145 | (append not-imp sf))))) | |
1146 | (assm tst k s)))))) | |
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))) | |
1154 | s) | |
1155 | ((and (pair? s) | |
1156 | (eq? (car s) 'if) | |
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))) | |
1161 | ((and (pair? s) | |
1162 | (equal? (car s) 'call-with-current-continuation) | |
1163 | (pair? (cdr s)) | |
1164 | (pair? (cadr s)) | |
1165 | (equal? (caadr s) 'lambda) | |
1166 | (pair? (cdadr s)) | |
1167 | (pair? (cadadr s)) | |
1168 | (null? (cdr (cadadr s))) | |
1169 | (pair? (cddadr 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))) | |
1190 | (null? (cddr 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 | |
1196 | (lambda (,k) | |
1197 | (let ((,fail (lambda () (,k ,f)))) | |
1198 | ,(assm tst `(,fail) s2)))))) | |
1199 | ((and #f | |
1200 | (pair? s) | |
1201 | (equal? (car s) 'let) | |
1202 | (pair? (cdr s)) | |
1203 | (pair? (cadr s)) | |
1204 | (pair? (caadr s)) | |
1205 | (pair? (cdaadr s)) | |
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))) | |
1213 | (null? (cdadr s)) | |
1214 | (pair? (cddr s)) | |
1215 | (null? (cdddr 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))))) | |
1221 | (guarantees | |
1222 | (lambda (code x) | |
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))) | |
1233 | #f) | |
1234 | (else (or (loop (car code)) (loop (cdr code))))))))) | |
1235 | (in (lambda (e l) | |
1236 | (or (member e l) | |
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))) | |
1243 | (cond (const-class | |
1244 | (let mem ((l l)) | |
1245 | (if (null? l) | |
1246 | #f | |
1247 | (let ((x (car l))) | |
1248 | (or (and (equal? (cadr x) (cadr srch)) | |
1249 | (disjoint? x) | |
1250 | (not (equal? | |
1251 | const-class | |
1252 | (car x)))) | |
1253 | (equal? | |
1254 | x | |
1255 | `(not (,const-class | |
1256 | ,(cadr srch)))) | |
1257 | (and (equal? (cadr x) (cadr srch)) | |
1258 | (equal-test? x) | |
1259 | (not (equal? | |
1260 | (caddr srch) | |
1261 | (caddr x)))) | |
1262 | (mem (cdr l))))))) | |
1263 | ((disjoint? srch) | |
1264 | (let mem ((l l)) | |
1265 | (if (null? l) | |
1266 | #f | |
1267 | (let ((x (car l))) | |
1268 | (or (and (equal? (cadr x) (cadr srch)) | |
1269 | (disjoint? x) | |
1270 | (not (equal? | |
1271 | (car x) | |
1272 | (car srch)))) | |
1273 | (mem (cdr l))))))) | |
1274 | ((eq? (car srch) 'list?) | |
1275 | (let mem ((l l)) | |
1276 | (if (null? l) | |
1277 | #f | |
1278 | (let ((x (car l))) | |
1279 | (or (and (equal? (cadr x) (cadr srch)) | |
1280 | (disjoint? x) | |
1281 | (not (memq (car x) | |
1282 | '(list? pair? | |
1283 | null?)))) | |
1284 | (mem (cdr l))))))) | |
1285 | ((vec-structure? srch) | |
1286 | (let mem ((l l)) | |
1287 | (if (null? l) | |
1288 | #f | |
1289 | (let ((x (car l))) | |
1290 | (or (and (equal? (cadr x) (cadr srch)) | |
1291 | (or (disjoint? x) | |
1292 | (vec-structure? x)) | |
1293 | (not (equal? | |
1294 | (car x) | |
1295 | 'vector?)) | |
1296 | (not (equal? | |
1297 | (car x) | |
1298 | (car srch)))) | |
1299 | (equal? | |
1300 | x | |
1301 | `(not (vector? ,(cadr srch)))) | |
1302 | (mem (cdr l))))))) | |
1303 | (else #f))))))) | |
1304 | (equal-test? | |
1305 | (lambda (tst) | |
1306 | (and (eq? (car tst) 'equal?) | |
1307 | (let ((p (caddr tst))) | |
1308 | (cond ((string? p) 'string?) | |
1309 | ((boolean? p) 'boolean?) | |
1310 | ((char? p) 'char?) | |
1311 | ((number? p) 'number?) | |
1312 | ((and (pair? p) | |
1313 | (pair? (cdr p)) | |
1314 | (null? (cddr p)) | |
1315 | (eq? 'quote (car p)) | |
1316 | (symbol? (cadr p))) | |
1317 | 'symbol?) | |
1318 | (else #f)))))) | |
1319 | (disjoint? | |
1320 | (lambda (tst) | |
1321 | (memq (car tst) match:disjoint-predicates))) | |
1322 | (vec-structure? | |
1323 | (lambda (tst) | |
1324 | (memq (car tst) match:vector-structures))) | |
1325 | (add-a (lambda (a) | |
1326 | (let ((new (and (pair? a) (assq (car a) c---rs)))) | |
1327 | (if new (cons (cadr new) (cdr a)) `(car ,a))))) | |
1328 | (add-d (lambda (a) | |
1329 | (let ((new (and (pair? a) (assq (car a) c---rs)))) | |
1330 | (if new (cons (cddr new) (cdr a)) `(cdr ,a))))) | |
1331 | (c---rs | |
1332 | '((car caar . cdar) | |
1333 | (cdr cadr . cddr) | |
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))) | |
1346 | (setter | |
1347 | (lambda (e p) | |
1348 | (let ((mk-setter | |
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)))) | |
1357 | ((eq? (car e) 'car) | |
1358 | `(let ((x ,(cadr e))) (lambda (y) (set-car! x y)))) | |
1359 | ((eq? (car e) 'cdr) | |
1360 | `(let ((x ,(cadr e))) (lambda (y) (set-cdr! x y)))) | |
1361 | ((let ((a (assq (car e) get-c---rs))) | |
1362 | (and a | |
1363 | `(let ((x (,(cadr a) ,(cadr e)))) | |
1364 | (lambda (y) (,(mk-setter (cddr a)) x y)))))) | |
1365 | (else | |
1366 | `(let ((x ,(cadr e))) | |
1367 | (lambda (y) (,(mk-setter (car e)) x y)))))))) | |
1368 | (getter | |
1369 | (lambda (e p) | |
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)))) | |
1377 | ((eq? (car e) 'car) | |
1378 | `(let ((x ,(cadr e))) (lambda () (car x)))) | |
1379 | ((eq? (car e) 'cdr) | |
1380 | `(let ((x ,(cadr e))) (lambda () (cdr x)))) | |
1381 | ((let ((a (assq (car e) get-c---rs))) | |
1382 | (and a | |
1383 | `(let ((x (,(cadr a) ,(cadr e)))) | |
1384 | (lambda () (,(cddr a) x)))))) | |
1385 | (else | |
1386 | `(let ((x ,(cadr e))) (lambda () (,(car e) x))))))) | |
1387 | (get-c---rs | |
1388 | '((caar car . car) | |
1389 | (cadr cdr . car) | |
1390 | (cdar car . cdr) | |
1391 | (cddr cdr . cdr) | |
1392 | (caaar caar . car) | |
1393 | (caadr cadr . car) | |
1394 | (cadar cdar . car) | |
1395 | (caddr cddr . car) | |
1396 | (cdaar caar . cdr) | |
1397 | (cdadr cadr . cdr) | |
1398 | (cddar cdar . cdr) | |
1399 | (cdddr cddr . cdr) | |
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))) | |
1416 | (symbol-append | |
1417 | (lambda l | |
1418 | (string->symbol | |
1419 | (apply string-append | |
1420 | (map (lambda (x) | |
1421 | (cond ((symbol? x) (symbol->string x)) | |
1422 | ((number? x) (number->string x)) | |
1423 | (else x))) | |
1424 | l))))) | |
1425 | (rac (lambda (l) | |
1426 | (if (null? (cdr l)) (car l) (rac (cdr l))))) | |
1427 | (rdc (lambda (l) | |
1428 | (if (null? (cdr l)) | |
1429 | '() | |
1430 | (cons (car l) (rdc (cdr l))))))) | |
1431 | (list genmatch genletrec gendefine pattern-var?))) | |
1432 | (defmacro | |
1433 | match | |
1434 | args | |
1435 | (cond ((and (list? args) | |
1436 | (<= 1 (length args)) | |
1437 | (match:andmap | |
1438 | (lambda (y) (and (list? y) (<= 2 (length y)))) | |
1439 | (cdr args))) | |
1440 | (let* ((exp (car args)) | |
1441 | (clauses (cdr args)) | |
1442 | (e (if (symbol? exp) exp (gentemp)))) | |
1443 | (if (symbol? exp) | |
1444 | ((car match:expanders) e clauses `(match ,@args)) | |
1445 | `(let ((,e ,exp)) | |
1446 | ,((car match:expanders) e clauses `(match ,@args)))))) | |
1447 | (else | |
1448 | (match:syntax-err | |
1449 | `(match ,@args) | |
1450 | "syntax error in")))) | |
1451 | (defmacro | |
1452 | match-lambda | |
1453 | args | |
1454 | (if (and (list? args) | |
1455 | (match:andmap | |
1456 | (lambda (g126) | |
1457 | (if (and (pair? g126) (list? (cdr g126))) | |
1458 | (pair? (cdr g126)) | |
1459 | #f)) | |
1460 | args)) | |
1461 | ((lambda () | |
1462 | (let ((e (gentemp))) | |
1463 | `(lambda (,e) (match ,e ,@args))))) | |
1464 | ((lambda () | |
1465 | (match:syntax-err | |
1466 | `(match-lambda ,@args) | |
1467 | "syntax error in"))))) | |
1468 | (defmacro | |
1469 | match-lambda* | |
1470 | args | |
1471 | (if (and (list? args) | |
1472 | (match:andmap | |
1473 | (lambda (g134) | |
1474 | (if (and (pair? g134) (list? (cdr g134))) | |
1475 | (pair? (cdr g134)) | |
1476 | #f)) | |
1477 | args)) | |
1478 | ((lambda () | |
1479 | (let ((e (gentemp))) | |
1480 | `(lambda ,e (match ,e ,@args))))) | |
1481 | ((lambda () | |
1482 | (match:syntax-err | |
1483 | `(match-lambda* ,@args) | |
1484 | "syntax error in"))))) | |
1485 | (defmacro | |
1486 | match-let | |
1487 | args | |
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)))))) | |
1495 | (g146 (lambda () | |
1496 | (match:syntax-err | |
1497 | `(match-let ,@args) | |
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))) | |
1504 | (if (pair? args) | |
1505 | (if (symbol? (car args)) | |
1506 | (if (and (pair? (cdr args)) (list? (cadr args))) | |
1507 | (let g161 ((g162 (cadr args)) (g160 '()) (g159 '())) | |
1508 | (if (null? g162) | |
1509 | (if (and (list? (cddr args)) (pair? (cddr args))) | |
1510 | ((lambda (name pat exp body) | |
1511 | (if (match:andmap (cadddr match:expanders) pat) | |
1512 | `(let ,@args) | |
1513 | `(letrec ((,name (match-lambda* (,pat ,@body)))) | |
1514 | (,name ,@exp)))) | |
1515 | (car args) | |
1516 | (reverse g159) | |
1517 | (reverse g160) | |
1518 | (cddr args)) | |
1519 | (g146)) | |
1520 | (if (and (pair? (car g162)) | |
1521 | (pair? (cdar g162)) | |
1522 | (null? (cddar g162))) | |
1523 | (g161 (cdr g162) | |
1524 | (cons (cadar g162) g160) | |
1525 | (cons (caar g162) g159)) | |
1526 | (g146)))) | |
1527 | (g146)) | |
1528 | (if (list? (car args)) | |
1529 | (if (match:andmap | |
1530 | (lambda (g167) | |
1531 | (if (and (pair? g167) | |
1532 | (g136 (car g167)) | |
1533 | (pair? (cdr g167))) | |
1534 | (null? (cddr g167)) | |
1535 | #f)) | |
1536 | (car args)) | |
1537 | (if (and (list? (cdr args)) (pair? (cdr args))) | |
1538 | ((lambda () `(let ,@args))) | |
1539 | (let g149 ((g150 (car args)) (g148 '()) (g147 '())) | |
1540 | (if (null? g150) | |
1541 | (g146) | |
1542 | (if (and (pair? (car g150)) | |
1543 | (pair? (cdar g150)) | |
1544 | (null? (cddar g150))) | |
1545 | (g149 (cdr g150) | |
1546 | (cons (cadar g150) g148) | |
1547 | (cons (caar g150) g147)) | |
1548 | (g146))))) | |
1549 | (if (and (pair? (car args)) | |
1550 | (pair? (caar 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 '())) | |
1557 | (if (null? g150) | |
1558 | (g146) | |
1559 | (if (and (pair? (car g150)) | |
1560 | (pair? (cdar g150)) | |
1561 | (null? (cddar g150))) | |
1562 | (g149 (cdr g150) | |
1563 | (cons (cadar g150) g148) | |
1564 | (cons (caar g150) g147)) | |
1565 | (g146))))) | |
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))) | |
1572 | (g145 (caaar args) | |
1573 | (cadaar args) | |
1574 | (caadar args) | |
1575 | (car (cdadar args)) | |
1576 | (cdr args)) | |
1577 | (let g149 ((g150 (car args)) (g148 '()) (g147 '())) | |
1578 | (if (null? g150) | |
1579 | (g146) | |
1580 | (if (and (pair? (car g150)) | |
1581 | (pair? (cdar g150)) | |
1582 | (null? (cddar g150))) | |
1583 | (g149 (cdr g150) | |
1584 | (cons (cadar g150) g148) | |
1585 | (cons (caar g150) g147)) | |
1586 | (g146))))) | |
1587 | (let g149 ((g150 (car args)) (g148 '()) (g147 '())) | |
1588 | (if (null? g150) | |
1589 | (if (and (list? (cdr args)) (pair? (cdr args))) | |
1590 | (g154 (reverse g147) (reverse g148) (cdr args)) | |
1591 | (g146)) | |
1592 | (if (and (pair? (car g150)) | |
1593 | (pair? (cdar g150)) | |
1594 | (null? (cddar g150))) | |
1595 | (g149 (cdr g150) | |
1596 | (cons (cadar g150) g148) | |
1597 | (cons (caar g150) g147)) | |
1598 | (g146)))))) | |
1599 | (let g149 ((g150 (car args)) (g148 '()) (g147 '())) | |
1600 | (if (null? g150) | |
1601 | (if (and (list? (cdr args)) (pair? (cdr args))) | |
1602 | (g154 (reverse g147) (reverse g148) (cdr args)) | |
1603 | (g146)) | |
1604 | (if (and (pair? (car g150)) | |
1605 | (pair? (cdar g150)) | |
1606 | (null? (cddar g150))) | |
1607 | (g149 (cdr g150) | |
1608 | (cons (cadar g150) g148) | |
1609 | (cons (caar g150) g147)) | |
1610 | (g146)))))) | |
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 '())) | |
1619 | (if (null? g150) | |
1620 | (g146) | |
1621 | (if (and (pair? (car g150)) | |
1622 | (pair? (cdar g150)) | |
1623 | (null? (cddar g150))) | |
1624 | (g149 (cdr g150) | |
1625 | (cons (cadar g150) g148) | |
1626 | (cons (caar g150) g147)) | |
1627 | (g146))))) | |
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))) | |
1634 | (g145 (caaar args) | |
1635 | (cadaar args) | |
1636 | (caadar args) | |
1637 | (car (cdadar args)) | |
1638 | (cdr args)) | |
1639 | (let g149 ((g150 (car args)) (g148 '()) (g147 '())) | |
1640 | (if (null? g150) | |
1641 | (g146) | |
1642 | (if (and (pair? (car g150)) | |
1643 | (pair? (cdar g150)) | |
1644 | (null? (cddar g150))) | |
1645 | (g149 (cdr g150) | |
1646 | (cons (cadar g150) g148) | |
1647 | (cons (caar g150) g147)) | |
1648 | (g146))))) | |
1649 | (let g149 ((g150 (car args)) (g148 '()) (g147 '())) | |
1650 | (if (null? g150) | |
1651 | (if (and (list? (cdr args)) (pair? (cdr args))) | |
1652 | (g154 (reverse g147) (reverse g148) (cdr args)) | |
1653 | (g146)) | |
1654 | (if (and (pair? (car g150)) | |
1655 | (pair? (cdar g150)) | |
1656 | (null? (cddar g150))) | |
1657 | (g149 (cdr g150) | |
1658 | (cons (cadar g150) g148) | |
1659 | (cons (caar g150) g147)) | |
1660 | (g146)))))) | |
1661 | (let g149 ((g150 (car args)) (g148 '()) (g147 '())) | |
1662 | (if (null? g150) | |
1663 | (if (and (list? (cdr args)) (pair? (cdr args))) | |
1664 | (g154 (reverse g147) (reverse g148) (cdr args)) | |
1665 | (g146)) | |
1666 | (if (and (pair? (car g150)) | |
1667 | (pair? (cdar g150)) | |
1668 | (null? (cddar g150))) | |
1669 | (g149 (cdr g150) | |
1670 | (cons (cadar g150) g148) | |
1671 | (cons (caar g150) g147)) | |
1672 | (g146))))) | |
1673 | (g146)))) | |
1674 | (g146)))) | |
1675 | (defmacro | |
1676 | match-let* | |
1677 | args | |
1678 | (let ((g176 (lambda () | |
1679 | (match:syntax-err | |
1680 | `(match-let* ,@args) | |
1681 | "syntax error in")))) | |
1682 | (if (pair? args) | |
1683 | (if (null? (car args)) | |
1684 | (if (and (list? (cdr args)) (pair? (cdr args))) | |
1685 | ((lambda (body) `(let* ,@args)) (cdr args)) | |
1686 | (g176)) | |
1687 | (if (and (pair? (car args)) | |
1688 | (pair? (caar args)) | |
1689 | (pair? (cdaar args)) | |
1690 | (null? (cddaar args)) | |
1691 | (list? (cdar args)) | |
1692 | (list? (cdr args)) | |
1693 | (pair? (cdr 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))))) | |
1698 | (caaar args) | |
1699 | (cadaar args) | |
1700 | (cdar args) | |
1701 | (cdr args)) | |
1702 | (g176))) | |
1703 | (g176)))) | |
1704 | (defmacro | |
1705 | match-letrec | |
1706 | args | |
1707 | (let ((g200 (cadddr match:expanders)) | |
1708 | (g199 (lambda (p1 e1 p2 e2 body) | |
1709 | `(match-letrec | |
1710 | (((,p1 unquote p2) (cons ,e1 ,e2))) | |
1711 | ,@body))) | |
1712 | (g195 (lambda () | |
1713 | (match:syntax-err | |
1714 | `(match-letrec ,@args) | |
1715 | "syntax error in"))) | |
1716 | (g194 (lambda (pat exp body) | |
1717 | `(match-letrec | |
1718 | ((,(list->vector pat) (vector ,@exp))) | |
1719 | ,@body))) | |
1720 | (g186 (lambda (pat exp body) | |
1721 | ((cadr match:expanders) | |
1722 | pat | |
1723 | exp | |
1724 | body | |
1725 | `(match-letrec ((,pat ,exp)) ,@body))))) | |
1726 | (if (pair? args) | |
1727 | (if (list? (car args)) | |
1728 | (if (match:andmap | |
1729 | (lambda (g206) | |
1730 | (if (and (pair? g206) | |
1731 | (g200 (car g206)) | |
1732 | (pair? (cdr g206))) | |
1733 | (null? (cddr g206)) | |
1734 | #f)) | |
1735 | (car args)) | |
1736 | (if (and (list? (cdr args)) (pair? (cdr args))) | |
1737 | ((lambda () `(letrec ,@args))) | |
1738 | (let g189 ((g190 (car args)) (g188 '()) (g187 '())) | |
1739 | (if (null? g190) | |
1740 | (g195) | |
1741 | (if (and (pair? (car g190)) | |
1742 | (pair? (cdar g190)) | |
1743 | (null? (cddar g190))) | |
1744 | (g189 (cdr g190) | |
1745 | (cons (cadar g190) g188) | |
1746 | (cons (caar g190) g187)) | |
1747 | (g195))))) | |
1748 | (if (and (pair? (car args)) | |
1749 | (pair? (caar 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 '())) | |
1756 | (if (null? g190) | |
1757 | (g195) | |
1758 | (if (and (pair? (car g190)) | |
1759 | (pair? (cdar g190)) | |
1760 | (null? (cddar g190))) | |
1761 | (g189 (cdr g190) | |
1762 | (cons (cadar g190) g188) | |
1763 | (cons (caar g190) g187)) | |
1764 | (g195))))) | |
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))) | |
1771 | (g199 (caaar args) | |
1772 | (cadaar args) | |
1773 | (caadar args) | |
1774 | (car (cdadar args)) | |
1775 | (cdr args)) | |
1776 | (let g189 ((g190 (car args)) (g188 '()) (g187 '())) | |
1777 | (if (null? g190) | |
1778 | (g195) | |
1779 | (if (and (pair? (car g190)) | |
1780 | (pair? (cdar g190)) | |
1781 | (null? (cddar g190))) | |
1782 | (g189 (cdr g190) | |
1783 | (cons (cadar g190) g188) | |
1784 | (cons (caar g190) g187)) | |
1785 | (g195))))) | |
1786 | (let g189 ((g190 (car args)) (g188 '()) (g187 '())) | |
1787 | (if (null? g190) | |
1788 | (if (and (list? (cdr args)) (pair? (cdr args))) | |
1789 | (g194 (reverse g187) (reverse g188) (cdr args)) | |
1790 | (g195)) | |
1791 | (if (and (pair? (car g190)) | |
1792 | (pair? (cdar g190)) | |
1793 | (null? (cddar g190))) | |
1794 | (g189 (cdr g190) | |
1795 | (cons (cadar g190) g188) | |
1796 | (cons (caar g190) g187)) | |
1797 | (g195)))))) | |
1798 | (let g189 ((g190 (car args)) (g188 '()) (g187 '())) | |
1799 | (if (null? g190) | |
1800 | (if (and (list? (cdr args)) (pair? (cdr args))) | |
1801 | (g194 (reverse g187) (reverse g188) (cdr args)) | |
1802 | (g195)) | |
1803 | (if (and (pair? (car g190)) | |
1804 | (pair? (cdar g190)) | |
1805 | (null? (cddar g190))) | |
1806 | (g189 (cdr g190) | |
1807 | (cons (cadar g190) g188) | |
1808 | (cons (caar g190) g187)) | |
1809 | (g195)))))) | |
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 '())) | |
1818 | (if (null? g190) | |
1819 | (g195) | |
1820 | (if (and (pair? (car g190)) | |
1821 | (pair? (cdar g190)) | |
1822 | (null? (cddar g190))) | |
1823 | (g189 (cdr g190) | |
1824 | (cons (cadar g190) g188) | |
1825 | (cons (caar g190) g187)) | |
1826 | (g195))))) | |
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))) | |
1833 | (g199 (caaar args) | |
1834 | (cadaar args) | |
1835 | (caadar args) | |
1836 | (car (cdadar args)) | |
1837 | (cdr args)) | |
1838 | (let g189 ((g190 (car args)) (g188 '()) (g187 '())) | |
1839 | (if (null? g190) | |
1840 | (g195) | |
1841 | (if (and (pair? (car g190)) | |
1842 | (pair? (cdar g190)) | |
1843 | (null? (cddar g190))) | |
1844 | (g189 (cdr g190) | |
1845 | (cons (cadar g190) g188) | |
1846 | (cons (caar g190) g187)) | |
1847 | (g195))))) | |
1848 | (let g189 ((g190 (car args)) (g188 '()) (g187 '())) | |
1849 | (if (null? g190) | |
1850 | (if (and (list? (cdr args)) (pair? (cdr args))) | |
1851 | (g194 (reverse g187) (reverse g188) (cdr args)) | |
1852 | (g195)) | |
1853 | (if (and (pair? (car g190)) | |
1854 | (pair? (cdar g190)) | |
1855 | (null? (cddar g190))) | |
1856 | (g189 (cdr g190) | |
1857 | (cons (cadar g190) g188) | |
1858 | (cons (caar g190) g187)) | |
1859 | (g195)))))) | |
1860 | (let g189 ((g190 (car args)) (g188 '()) (g187 '())) | |
1861 | (if (null? g190) | |
1862 | (if (and (list? (cdr args)) (pair? (cdr args))) | |
1863 | (g194 (reverse g187) (reverse g188) (cdr args)) | |
1864 | (g195)) | |
1865 | (if (and (pair? (car g190)) | |
1866 | (pair? (cdar g190)) | |
1867 | (null? (cddar g190))) | |
1868 | (g189 (cdr g190) | |
1869 | (cons (cadar g190) g188) | |
1870 | (cons (caar g190) g187)) | |
1871 | (g195))))) | |
1872 | (g195))) | |
1873 | (g195)))) | |
1874 | (defmacro | |
1875 | match-define | |
1876 | args | |
1877 | (let ((g210 (cadddr match:expanders)) | |
1878 | (g209 (lambda () | |
1879 | (match:syntax-err | |
1880 | `(match-define ,@args) | |
1881 | "syntax error in")))) | |
1882 | (if (pair? args) | |
1883 | (if (g210 (car args)) | |
1884 | (if (and (pair? (cdr args)) (null? (cddr args))) | |
1885 | ((lambda () `(begin (define ,@args)))) | |
1886 | (g209)) | |
1887 | (if (and (pair? (cdr args)) (null? (cddr args))) | |
1888 | ((lambda (pat exp) | |
1889 | ((caddr match:expanders) | |
1890 | pat | |
1891 | exp | |
1892 | `(match-define ,@args))) | |
1893 | (car args) | |
1894 | (cadr args)) | |
1895 | (g209))) | |
1896 | (g209)))) | |
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?) | |
1901 | (defmacro | |
1902 | defstruct | |
1903 | args | |
1904 | (let ((field? | |
1905 | (lambda (x) | |
1906 | (if (symbol? x) | |
1907 | ((lambda () #t)) | |
1908 | (if (and (pair? x) | |
1909 | (symbol? (car x)) | |
1910 | (pair? (cdr x)) | |
1911 | (symbol? (cadr x)) | |
1912 | (null? (cddr x))) | |
1913 | ((lambda () #t)) | |
1914 | ((lambda () #f)))))) | |
1915 | (selector-name | |
1916 | (lambda (x) | |
1917 | (if (symbol? x) | |
1918 | ((lambda () x)) | |
1919 | (if (and (pair? x) | |
1920 | (symbol? (car x)) | |
1921 | (pair? (cdr x)) | |
1922 | (null? (cddr x))) | |
1923 | ((lambda (s) s) (car x)) | |
1924 | (match:error x))))) | |
1925 | (mutator-name | |
1926 | (lambda (x) | |
1927 | (if (symbol? x) | |
1928 | ((lambda () #f)) | |
1929 | (if (and (pair? x) | |
1930 | (pair? (cdr x)) | |
1931 | (symbol? (cadr x)) | |
1932 | (null? (cddr x))) | |
1933 | ((lambda (s) s) (cadr x)) | |
1934 | (match:error x))))) | |
1935 | (filter-map-with-index | |
1936 | (lambda (f l) | |
1937 | (letrec ((mapi (lambda (l i) | |
1938 | (cond ((null? l) '()) | |
1939 | ((f (car l) i) | |
1940 | => | |
1941 | (lambda (x) | |
1942 | (cons x (mapi (cdr l) (+ 1 i))))) | |
1943 | (else (mapi (cdr l) (+ 1 i))))))) | |
1944 | (mapi l 1))))) | |
1945 | (let ((g227 (lambda () | |
1946 | (match:syntax-err | |
1947 | `(defstruct ,@args) | |
1948 | "syntax error in")))) | |
1949 | (if (and (pair? args) | |
1950 | (symbol? (car args)) | |
1951 | (pair? (cdr args)) | |
1952 | (symbol? (cadr args)) | |
1953 | (pair? (cddr args)) | |
1954 | (symbol? (caddr args)) | |
1955 | (list? (cdddr args))) | |
1956 | (let g229 ((g230 (cdddr args)) (g228 '())) | |
1957 | (if (null? g230) | |
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 | |
1962 | (gentemp) | |
1963 | `',(match:make-structure-tag name))) | |
1964 | (vectorp | |
1965 | (cond ((eq? match:structure-control 'disjoint) | |
1966 | 'match:primitive-vector?) | |
1967 | ((eq? match:structure-control 'vector) | |
1968 | 'vector?)))) | |
1969 | (cond ((eq? match:structure-control 'disjoint) | |
1970 | (if (eq? vector? match:primitive-vector?) | |
1971 | (set! vector? | |
1972 | (lambda (v) | |
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)))) | |
1985 | (else | |
1986 | (match:syntax-err | |
1987 | '(vector disjoint) | |
1988 | "invalid value for match:structure-control, legal values are"))) | |
1989 | `(begin | |
1990 | ,@(if match:runtime-structures | |
1991 | `((define ,tag (match:make-structure-tag ',name))) | |
1992 | '()) | |
1993 | (define ,constructor | |
1994 | (lambda ,selectors (vector ,tag ,@selectors))) | |
1995 | (define ,predicate | |
1996 | (lambda (obj) | |
1997 | (and (,vectorp obj) | |
1998 | (= (vector-length obj) ,(+ 1 (length selectors))) | |
1999 | (eq? (vector-ref obj 0) ,tag)))) | |
2000 | ,@(filter-map-with-index | |
2001 | (lambda (n i) | |
2002 | `(define ,n (lambda (obj) (vector-ref obj ,i)))) | |
2003 | selectors) | |
2004 | ,@(filter-map-with-index | |
2005 | (lambda (n i) | |
2006 | (and n | |
2007 | `(define ,n | |
2008 | (lambda (obj newval) | |
2009 | (vector-set! obj ,i newval))))) | |
2010 | mutators)))) | |
2011 | (car args) | |
2012 | (cadr args) | |
2013 | (caddr args) | |
2014 | (reverse g228)) | |
2015 | (if (field? (car g230)) | |
2016 | (g229 (cdr g230) (cons (car g230) g228)) | |
2017 | (g227)))) | |
2018 | (g227))))) | |
2019 | (defmacro | |
2020 | define-structure | |
2021 | args | |
2022 | (let ((g242 (lambda () | |
2023 | (match:syntax-err | |
2024 | `(define-structure ,@args) | |
2025 | "syntax error in")))) | |
2026 | (if (and (pair? args) | |
2027 | (pair? (car args)) | |
2028 | (list? (cdar args))) | |
2029 | (if (null? (cdr args)) | |
2030 | ((lambda (name id1) | |
2031 | `(define-structure (,name ,@id1) ())) | |
2032 | (caar args) | |
2033 | (cdar args)) | |
2034 | (if (and (pair? (cdr args)) (list? (cadr args))) | |
2035 | (let g239 ((g240 (cadr args)) (g238 '()) (g237 '())) | |
2036 | (if (null? g240) | |
2037 | (if (null? (cddr args)) | |
2038 | ((lambda (name id1 id2 val) | |
2039 | (let ((mk-id (lambda (id) | |
2040 | (if (and (pair? id) | |
2041 | (equal? (car id) '@) | |
2042 | (pair? (cdr id)) | |
2043 | (symbol? (cadr id)) | |
2044 | (null? (cddr 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)))) | |
2050 | (caar args) | |
2051 | (cdar args) | |
2052 | (reverse g237) | |
2053 | (reverse g238)) | |
2054 | (g242)) | |
2055 | (if (and (pair? (car g240)) | |
2056 | (pair? (cdar g240)) | |
2057 | (null? (cddar g240))) | |
2058 | (g239 (cdr g240) | |
2059 | (cons (cadar g240) g238) | |
2060 | (cons (caar g240) g237)) | |
2061 | (g242)))) | |
2062 | (g242))) | |
2063 | (g242)))) | |
2064 | (defmacro | |
2065 | define-const-structure | |
2066 | args | |
2067 | (let ((field? | |
2068 | (lambda (id) | |
2069 | (if (symbol? id) | |
2070 | ((lambda () #t)) | |
2071 | (if (and (pair? id) | |
2072 | (equal? (car id) '!) | |
2073 | (pair? (cdr id)) | |
2074 | (symbol? (cadr id)) | |
2075 | (null? (cddr id))) | |
2076 | ((lambda () #t)) | |
2077 | ((lambda () #f)))))) | |
2078 | (field-name | |
2079 | (lambda (x) (if (symbol? x) x (cadr x)))) | |
2080 | (has-mutator? (lambda (x) (not (symbol? x)))) | |
2081 | (filter-map-with-index | |
2082 | (lambda (f l) | |
2083 | (letrec ((mapi (lambda (l i) | |
2084 | (cond ((null? l) '()) | |
2085 | ((f (car l) i) | |
2086 | => | |
2087 | (lambda (x) | |
2088 | (cons x (mapi (cdr l) (+ 1 i))))) | |
2089 | (else (mapi (cdr l) (+ 1 i))))))) | |
2090 | (mapi l 1)))) | |
2091 | (symbol-append | |
2092 | (lambda l | |
2093 | (string->symbol | |
2094 | (apply string-append | |
2095 | (map (lambda (x) | |
2096 | (cond ((symbol? x) (symbol->string x)) | |
2097 | ((number? x) (number->string x)) | |
2098 | (else x))) | |
2099 | l)))))) | |
2100 | (let ((g266 (lambda () | |
2101 | (match:syntax-err | |
2102 | `(define-const-structure ,@args) | |
2103 | "syntax error in")))) | |
2104 | (if (and (pair? args) | |
2105 | (pair? (car args)) | |
2106 | (list? (cdar args))) | |
2107 | (if (null? (cdr args)) | |
2108 | ((lambda (name id1) | |
2109 | `(define-const-structure (,name ,@id1) ())) | |
2110 | (caar args) | |
2111 | (cdar args)) | |
2112 | (if (symbol? (caar args)) | |
2113 | (let g259 ((g260 (cdar args)) (g258 '())) | |
2114 | (if (null? g260) | |
2115 | (if (and (pair? (cdr args)) (list? (cadr args))) | |
2116 | (let g263 ((g264 (cadr args)) (g262 '()) (g261 '())) | |
2117 | (if (null? g264) | |
2118 | (if (null? (cddr args)) | |
2119 | ((lambda (name id1 id2 val) | |
2120 | (let* ((id1id2 (append id1 id2)) | |
2121 | (raw-constructor | |
2122 | (symbol-append 'make-raw- name)) | |
2123 | (constructor (symbol-append 'make- name)) | |
2124 | (predicate (symbol-append name '?))) | |
2125 | `(begin | |
2126 | (defstruct | |
2127 | ,name | |
2128 | ,raw-constructor | |
2129 | ,predicate | |
2130 | ,@(filter-map-with-index | |
2131 | (lambda (arg i) | |
2132 | (if (has-mutator? arg) | |
2133 | `(,(symbol-append name '- i) | |
2134 | ,(symbol-append | |
2135 | 'set- | |
2136 | name | |
2137 | '- | |
2138 | i | |
2139 | '!)) | |
2140 | (symbol-append name '- i))) | |
2141 | id1id2)) | |
2142 | ,(let* ((make-fresh | |
2143 | (lambda (x) | |
2144 | (if (eq? '_ x) (gentemp) x))) | |
2145 | (names1 | |
2146 | (map make-fresh | |
2147 | (map field-name id1))) | |
2148 | (names2 | |
2149 | (map make-fresh | |
2150 | (map field-name id2)))) | |
2151 | `(define ,constructor | |
2152 | (lambda ,names1 | |
2153 | (let* ,(map list names2 val) | |
2154 | (,raw-constructor | |
2155 | ,@names1 | |
2156 | ,@names2))))) | |
2157 | ,@(filter-map-with-index | |
2158 | (lambda (field i) | |
2159 | (if (eq? (field-name field) '_) | |
2160 | #f | |
2161 | `(define (unquote | |
2162 | (symbol-append | |
2163 | name | |
2164 | '- | |
2165 | (field-name field))) | |
2166 | ,(symbol-append name '- i)))) | |
2167 | id1id2) | |
2168 | ,@(filter-map-with-index | |
2169 | (lambda (field i) | |
2170 | (if (or (eq? (field-name field) '_) | |
2171 | (not (has-mutator? field))) | |
2172 | #f | |
2173 | `(define (unquote | |
2174 | (symbol-append | |
2175 | 'set- | |
2176 | name | |
2177 | '- | |
2178 | (field-name field) | |
2179 | '!)) | |
2180 | ,(symbol-append | |
2181 | 'set- | |
2182 | name | |
2183 | '- | |
2184 | i | |
2185 | '!)))) | |
2186 | id1id2)))) | |
2187 | (caar args) | |
2188 | (reverse g258) | |
2189 | (reverse g261) | |
2190 | (reverse g262)) | |
2191 | (g266)) | |
2192 | (if (and (pair? (car g264)) | |
2193 | (field? (caar g264)) | |
2194 | (pair? (cdar g264)) | |
2195 | (null? (cddar g264))) | |
2196 | (g263 (cdr g264) | |
2197 | (cons (cadar g264) g262) | |
2198 | (cons (caar g264) g261)) | |
2199 | (g266)))) | |
2200 | (g266)) | |
2201 | (if (field? (car g260)) | |
2202 | (g259 (cdr g260) (cons (car g260) g258)) | |
2203 | (g266)))) | |
2204 | (g266))) | |
2205 | (g266))))) | |
2206 | (define home-directory | |
2207 | (or (getenv "HOME") | |
2208 | (error "environment variable HOME is not defined"))) | |
2209 | (defmacro recur args `(let ,@args)) | |
2210 | (defmacro | |
2211 | rec | |
2212 | args | |
2213 | (match args | |
2214 | (((? symbol? x) v) `(letrec ((,x ,v)) ,x)))) | |
2215 | (defmacro | |
2216 | parameterize | |
2217 | args | |
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 | |
2223 | (lambda l | |
2224 | (string->symbol | |
2225 | (apply string-append | |
2226 | (map (lambda (x) (format #f "~a" x)) l))))) | |
2227 | (define gensym gentemp) | |
2228 | (define andmap | |
2229 | (lambda (f . lists) | |
2230 | (cond ((null? (car lists)) (and)) | |
2231 | ((null? (cdr (car lists))) | |
2232 | (apply f (map car lists))) | |
2233 | (else | |
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)))) | |
2239 | (defmacro | |
2240 | when | |
2241 | args | |
2242 | (match args | |
2243 | ((tst body __1) | |
2244 | `(if ,tst (begin ,@body (void)) (void))))) | |
2245 | (defmacro | |
2246 | unless | |
2247 | args | |
2248 | (match args | |
2249 | ((tst body __1) | |
2250 | `(if ,tst (void) (begin ,@body (void)))))) | |
2251 | (define should-never-reach | |
2252 | (lambda (form) | |
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 _)) | |
2261 | (defmacro | |
2262 | record | |
2263 | args | |
2264 | (match args | |
2265 | ((((? symbol? id) exp) ...) | |
2266 | `(make-record | |
2267 | (list ,@(map (lambda (i x) `(cons ',i ,x)) id exp)))) | |
2268 | (_ (slib:error "syntax error at " `(record ,@args))))) | |
2269 | (defmacro | |
2270 | field | |
2271 | args | |
2272 | (match args | |
2273 | (((? symbol? id) exp) | |
2274 | `(match ,exp | |
2275 | (($ record x) | |
2276 | (match (assq ',id x) | |
2277 | (#f | |
2278 | (slib:error | |
2279 | "no field " | |
2280 | ,id | |
2281 | 'in | |
2282 | (cons 'record (map car x)))) | |
2283 | ((_ . x) x))) | |
2284 | (_ (slib:error "not a record: " '(field ,id _))))) | |
2285 | (_ (slib:error "syntax error at " `(field ,@args))))) | |
2286 | (define-const-structure (module _)) | |
2287 | (defmacro | |
2288 | module | |
2289 | args | |
2290 | (match args | |
2291 | (((i ...) defs ...) | |
2292 | `(let () | |
2293 | ,@defs | |
2294 | (make-module | |
2295 | (record ,@(map (lambda (x) (list x x)) i))))) | |
2296 | (_ (slib:error "syntax error at " `(module ,@args))))) | |
2297 | (defmacro | |
2298 | import | |
2299 | args | |
2300 | (match args | |
2301 | ((((mod defs ...) ...) body __1) | |
2302 | (let* ((m (map (lambda (_) (gentemp)) mod)) | |
2303 | (newdefs | |
2304 | (let loop ((mod-names m) (l-defs defs)) | |
2305 | (if (null? mod-names) | |
2306 | '() | |
2307 | (append | |
2308 | (let ((m (car mod-names))) | |
2309 | (map (match-lambda | |
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))) | |
2314 | (car l-defs))) | |
2315 | (loop (cdr mod-names) (cdr l-defs))))))) | |
2316 | `(let (unquote | |
2317 | (map (lambda (m mod) | |
2318 | `(,m (match ,mod (($ module x) x)))) | |
2319 | m | |
2320 | mod)) | |
2321 | (let ,newdefs body ...)))))) | |
2322 | (define raise | |
2323 | (lambda vals | |
2324 | (slib:error "Unhandled exception " vals))) | |
2325 | (defmacro | |
2326 | fluid-let | |
2327 | args | |
2328 | (match args | |
2329 | ((((x val) ...) body __1) | |
2330 | (let ((old-x (map (lambda (_) (gentemp)) x)) | |
2331 | (swap-x (map (lambda (_) (gentemp)) x)) | |
2332 | (swap (gentemp))) | |
2333 | `(let ,(map list old-x val) | |
2334 | (let ((,swap | |
2335 | (lambda () | |
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)) | |
2339 | x | |
2340 | swap-x))))) | |
2341 | (dynamic-wind ,swap (lambda () ,@body) ,swap))))) | |
2342 | (_ (slib:error | |
2343 | "syntax error at " | |
2344 | `(fluid-let ,@args))))) | |
2345 | (defmacro | |
2346 | handle | |
2347 | args | |
2348 | (match args | |
2349 | ((e h) | |
2350 | (let ((k (gentemp)) (exn (gentemp))) | |
2351 | `((call-with-current-continuation | |
2352 | (lambda (k) | |
2353 | (fluid-let | |
2354 | ((raise (lambda ,exn (k (lambda () (apply ,h ,exn)))))) | |
2355 | (let ((v ,e)) (lambda () v)))))))) | |
2356 | (_ (slib:error "syntax error in " `(handle ,@args))))) | |
2357 | (defmacro | |
2358 | : | |
2359 | args | |
2360 | (match args ((typeexp exp) exp))) | |
2361 | (defmacro | |
2362 | module: | |
2363 | args | |
2364 | (match args | |
2365 | ((((i type) ...) defs ...) | |
2366 | `(let () | |
2367 | ,@defs | |
2368 | (make-module | |
2369 | (record | |
2370 | ,@(map (lambda (i type) `(,i (: ,type ,i))) i type))))))) | |
2371 | (defmacro | |
2372 | define: | |
2373 | args | |
2374 | (match args | |
2375 | ((name type exp) `(define ,name (: ,type ,exp))))) | |
2376 | (define st:failure | |
2377 | (lambda (chk fmt . args) | |
2378 | (slib:error | |
2379 | (apply format | |
2380 | #f | |
2381 | (string-append "~a : " fmt) | |
2382 | chk | |
2383 | args)))) | |
2384 | (defmacro | |
2385 | check-bound | |
2386 | args | |
2387 | (match args | |
2388 | ((var) var) | |
2389 | (x (st:failure `(check-bound ,@x) "syntax-error")))) | |
2390 | (defmacro | |
2391 | clash | |
2392 | args | |
2393 | (match args | |
2394 | ((name info ...) name) | |
2395 | (x (st:failure `(clash ,@x) "syntax error")))) | |
2396 | (defmacro | |
2397 | check-lambda | |
2398 | args | |
2399 | (match args | |
2400 | (((id info ...) (? symbol? args) body __1) | |
2401 | `(lambda ,args | |
2402 | (check-increment-counter ,id) | |
2403 | ,@body)) | |
2404 | (((id info ...) args body __1) | |
2405 | (let* ((n 0) | |
2406 | (chk (let loop ((a args) (nargs 0)) | |
2407 | (cond ((pair? a) (loop (cdr a) (+ 1 nargs))) | |
2408 | ((null? a) | |
2409 | (set! n nargs) | |
2410 | `(= ,nargs (length args))) | |
2411 | (else | |
2412 | (set! n nargs) | |
2413 | `(<= ,nargs (length args)))))) | |
2414 | (incr (if (number? id) | |
2415 | `(check-increment-counter ,id) | |
2416 | #f))) | |
2417 | `(let ((lam (lambda ,args ,@body))) | |
2418 | (lambda args | |
2419 | ,incr | |
2420 | (if ,chk | |
2421 | (apply lam args) | |
2422 | ,(if (eq? '= (car chk)) | |
2423 | `(st:failure | |
2424 | '(check-lambda ,id ,@info) | |
2425 | "requires ~a arguments, passed: ~a" | |
2426 | ,n | |
2427 | args) | |
2428 | `(st:failure | |
2429 | '(check-lambda ,id ,@info) | |
2430 | "requires >= ~a arguments, passed: ~a" | |
2431 | ,n | |
2432 | args))))))) | |
2433 | (x (st:failure `(check-lambda ,@x) "syntax error")))) | |
2434 | (defmacro | |
2435 | check-ap | |
2436 | args | |
2437 | (match args | |
2438 | (((id info ...) (? symbol? f) args ...) | |
2439 | `(begin | |
2440 | (check-increment-counter ,id) | |
2441 | (if (procedure? ,f) | |
2442 | (,f ,@args) | |
2443 | (st:failure | |
2444 | '(check-ap ,id ,@info) | |
2445 | "not a procedure: ~a" | |
2446 | ,f)))) | |
2447 | (((id info ...) f args ...) | |
2448 | `((lambda (proc . args) | |
2449 | (check-increment-counter ,id) | |
2450 | (if (procedure? proc) | |
2451 | (apply proc args) | |
2452 | (st:failure | |
2453 | '(check-ap ,id ,@info) | |
2454 | "not a procedure: ~a" | |
2455 | proc))) | |
2456 | ,f | |
2457 | ,@args)) | |
2458 | (x (st:failure `(check-ap ,@x) "syntax error")))) | |
2459 | (defmacro | |
2460 | check-field | |
2461 | args | |
2462 | (match args | |
2463 | (((id info ...) (? symbol? f) exp) | |
2464 | `(match ,exp | |
2465 | (($ record x) | |
2466 | (match (assq ',f x) | |
2467 | (#f | |
2468 | (st:failure | |
2469 | '(check-field ,id ,@info) | |
2470 | "no ~a field in (record ~a)" | |
2471 | ',f | |
2472 | (map car x))) | |
2473 | ((_ . x) x))) | |
2474 | (v (st:failure | |
2475 | '(check-field ,id ,@info) | |
2476 | "not a record: ~a" | |
2477 | v)))) | |
2478 | (x (st:failure `(check-field ,@x) "syntax error")))) | |
2479 | (defmacro | |
2480 | check-match | |
2481 | args | |
2482 | (match args | |
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) | |
2487 | ((? symbol?) #t) | |
2488 | (('and subp ...) (andmap symbol? subp)) | |
2489 | (_ #f)) | |
2490 | `(begin | |
2491 | (check-increment-counter ,id) | |
2492 | (match ,exp ,@clause)) | |
2493 | `(begin | |
2494 | (check-increment-counter ,id) | |
2495 | (match ,exp | |
2496 | ,@clause | |
2497 | (x (st:failure | |
2498 | '(check-match ,id ,@info) | |
2499 | "no matching clause for ~a" | |
2500 | x))))))) | |
2501 | (x (st:failure `(check-match ,@x) "syntax error")))) | |
2502 | (defmacro | |
2503 | check-: | |
2504 | args | |
2505 | (match args | |
2506 | (((id info ...) typeexp exp) | |
2507 | `(st:failure | |
2508 | '(check-: ,id ,@info) | |
2509 | "static type annotation reached")) | |
2510 | (x (st:failure `(check-: ,@x) "syntax error")))) | |
2511 | (defmacro | |
2512 | make-check-typed | |
2513 | args | |
2514 | (match args | |
2515 | ((prim) | |
2516 | (let ((chkprim (symbol-append 'check- prim))) | |
2517 | (list 'defmacro | |
2518 | chkprim | |
2519 | 'id | |
2520 | (list 'quasiquote | |
2521 | `(lambda a | |
2522 | (check-increment-counter (,'unquote (car id))) | |
2523 | (if (null? a) | |
2524 | (,prim) | |
2525 | (st:failure | |
2526 | (cons ',chkprim '(,'unquote id)) | |
2527 | "invalid arguments: ~a" | |
2528 | a))))))) | |
2529 | ((prim '_) | |
2530 | (let ((chkprim (symbol-append 'check- prim))) | |
2531 | (list 'defmacro | |
2532 | chkprim | |
2533 | 'id | |
2534 | (list 'quasiquote | |
2535 | `(lambda a | |
2536 | (check-increment-counter (,'unquote (car id))) | |
2537 | (if (= 1 (length a)) | |
2538 | (,prim (car a)) | |
2539 | (st:failure | |
2540 | (cons ',chkprim '(,'unquote id)) | |
2541 | "invalid arguments: ~a" | |
2542 | a))))))) | |
2543 | ((prim type1) | |
2544 | (let ((chkprim (symbol-append 'check- prim))) | |
2545 | (list 'defmacro | |
2546 | chkprim | |
2547 | 'id | |
2548 | (list 'quasiquote | |
2549 | `(lambda a | |
2550 | (check-increment-counter (,'unquote (car id))) | |
2551 | (if (and (= 1 (length a)) (,type1 (car a))) | |
2552 | (,prim (car a)) | |
2553 | (st:failure | |
2554 | (cons ',chkprim '(,'unquote id)) | |
2555 | "invalid arguments: ~a" | |
2556 | a))))))) | |
2557 | ((prim '_ '_) | |
2558 | (let ((chkprim (symbol-append 'check- prim))) | |
2559 | (list 'defmacro | |
2560 | chkprim | |
2561 | 'id | |
2562 | (list 'quasiquote | |
2563 | `(lambda a | |
2564 | (check-increment-counter (,'unquote (car id))) | |
2565 | (if (= 2 (length a)) | |
2566 | (,prim (car a) (cadr a)) | |
2567 | (st:failure | |
2568 | (cons ',chkprim '(,'unquote id)) | |
2569 | "invalid arguments: ~a" | |
2570 | a))))))) | |
2571 | ((prim '_ type2) | |
2572 | (let ((chkprim (symbol-append 'check- prim))) | |
2573 | (list 'defmacro | |
2574 | chkprim | |
2575 | 'id | |
2576 | (list 'quasiquote | |
2577 | `(lambda a | |
2578 | (check-increment-counter (,'unquote (car id))) | |
2579 | (if (and (= 2 (length a)) (,type2 (cadr a))) | |
2580 | (,prim (car a) (cadr a)) | |
2581 | (st:failure | |
2582 | (cons ',chkprim '(,'unquote id)) | |
2583 | "invalid arguments: ~a" | |
2584 | a))))))) | |
2585 | ((prim type1 '_) | |
2586 | (let ((chkprim (symbol-append 'check- prim))) | |
2587 | (list 'defmacro | |
2588 | chkprim | |
2589 | 'id | |
2590 | (list 'quasiquote | |
2591 | `(lambda a | |
2592 | (check-increment-counter (,'unquote (car id))) | |
2593 | (if (and (= 2 (length a)) (,type1 (car a))) | |
2594 | (,prim (car a) (cadr a)) | |
2595 | (st:failure | |
2596 | (cons ',chkprim '(,'unquote id)) | |
2597 | "invalid arguments: ~a" | |
2598 | a))))))) | |
2599 | ((prim type1 type2) | |
2600 | (let ((chkprim (symbol-append 'check- prim))) | |
2601 | (list 'defmacro | |
2602 | chkprim | |
2603 | 'id | |
2604 | (list 'quasiquote | |
2605 | `(lambda a | |
2606 | (check-increment-counter (,'unquote (car id))) | |
2607 | (if (and (= 2 (length a)) | |
2608 | (,type1 (car a)) | |
2609 | (,type2 (cadr a))) | |
2610 | (,prim (car a) (cadr a)) | |
2611 | (st:failure | |
2612 | (cons ',chkprim '(,'unquote id)) | |
2613 | "invalid arguments: ~a" | |
2614 | a))))))) | |
2615 | ((prim types ...) | |
2616 | (let ((nargs (length types)) | |
2617 | (chkprim (symbol-append 'check- prim)) | |
2618 | (types (map (match-lambda ('_ '(lambda (_) #t)) (x x)) | |
2619 | types))) | |
2620 | (list 'defmacro | |
2621 | chkprim | |
2622 | 'id | |
2623 | (list 'quasiquote | |
2624 | `(lambda a | |
2625 | (check-increment-counter (,'unquote (car id))) | |
2626 | (if (and (= ,nargs (length a)) | |
2627 | (andmap | |
2628 | (lambda (f a) (f a)) | |
2629 | (list ,@types) | |
2630 | a)) | |
2631 | (apply ,prim a) | |
2632 | (st:failure | |
2633 | (cons ',chkprim '(,'unquote id)) | |
2634 | "invalid arguments: ~a" | |
2635 | a))))))))) | |
2636 | (defmacro | |
2637 | make-check-selector | |
2638 | args | |
2639 | (match args | |
2640 | ((prim pat) | |
2641 | (let ((chkprim (symbol-append 'check- prim))) | |
2642 | (list 'defmacro | |
2643 | chkprim | |
2644 | 'id | |
2645 | (list 'quasiquote | |
2646 | `(lambda a | |
2647 | (check-increment-counter (,'unquote (car id))) | |
2648 | (match a | |
2649 | ((,pat) x) | |
2650 | (_ (st:failure | |
2651 | (cons ',chkprim '(,'unquote id)) | |
2652 | "invalid arguments: ~a" | |
2653 | 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 | |
2690 | caaaar | |
2691 | ((((x . _) . _) . _) . _)) | |
2692 | (make-check-selector | |
2693 | caaadr | |
2694 | (_ ((x . _) . _) . _)) | |
2695 | (make-check-selector | |
2696 | caadar | |
2697 | ((_ (x . _) . _) . _)) | |
2698 | (make-check-selector caaddr (_ _ (x . _) . _)) | |
2699 | (make-check-selector | |
2700 | cadaar | |
2701 | (((_ x . _) . _) . _)) | |
2702 | (make-check-selector cadadr (_ (_ x . _) . _)) | |
2703 | (make-check-selector caddar ((_ _ x . _) . _)) | |
2704 | (make-check-selector cadddr (_ _ _ x . _)) | |
2705 | (make-check-selector | |
2706 | cdaaar | |
2707 | ((((_ . x) . _) . _) . _)) | |
2708 | (make-check-selector | |
2709 | cdaadr | |
2710 | (_ ((_ . x) . _) . _)) | |
2711 | (make-check-selector | |
2712 | cdadar | |
2713 | ((_ (_ . x) . _) . _)) | |
2714 | (make-check-selector cdaddr (_ _ (_ . x) . _)) | |
2715 | (make-check-selector | |
2716 | cddaar | |
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? _) | |
2723 | (defmacro | |
2724 | check-list | |
2725 | id | |
2726 | `(lambda a | |
2727 | (check-increment-counter ,(car id)) | |
2728 | (apply list a))) | |
2729 | (make-check-typed length list?) | |
2730 | (defmacro | |
2731 | check-append | |
2732 | id | |
2733 | `(lambda a | |
2734 | (check-increment-counter ,(car id)) | |
2735 | (let loop ((b a)) | |
2736 | (match b | |
2737 | (() #t) | |
2738 | ((l) #t) | |
2739 | (((? list?) . y) (loop y)) | |
2740 | (_ (st:failure | |
2741 | (cons 'check-append ',id) | |
2742 | "invalid arguments: ~a" | |
2743 | a)))) | |
2744 | (apply append 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?) | |
2751 | (defmacro | |
2752 | check-assq | |
2753 | id | |
2754 | `(lambda a | |
2755 | (check-increment-counter ,(car id)) | |
2756 | (if (and (= 2 (length a)) | |
2757 | (list? (cadr a)) | |
2758 | (andmap pair? (cadr a))) | |
2759 | (assq (car a) (cadr a)) | |
2760 | (st:failure | |
2761 | (cons 'check-assq ',id) | |
2762 | "invalid arguments: ~a" | |
2763 | a)))) | |
2764 | (defmacro | |
2765 | check-assv | |
2766 | id | |
2767 | `(lambda a | |
2768 | (check-increment-counter ,(car id)) | |
2769 | (if (and (= 2 (length a)) | |
2770 | (list? (cadr a)) | |
2771 | (andmap pair? (cadr a))) | |
2772 | (assv (car a) (cadr a)) | |
2773 | (st:failure | |
2774 | (cons 'check-assv ',id) | |
2775 | "invalid arguments: ~a" | |
2776 | a)))) | |
2777 | (defmacro | |
2778 | check-assoc | |
2779 | id | |
2780 | `(lambda a | |
2781 | (check-increment-counter ,(car id)) | |
2782 | (if (and (= 2 (length a)) | |
2783 | (list? (cadr a)) | |
2784 | (andmap pair? (cadr a))) | |
2785 | (assoc (car a) (cadr a)) | |
2786 | (st:failure | |
2787 | (cons 'check-assoc ',id) | |
2788 | "invalid arguments: ~a" | |
2789 | 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?) | |
2798 | (defmacro | |
2799 | check-= | |
2800 | id | |
2801 | `(lambda a | |
2802 | (check-increment-counter ,(car id)) | |
2803 | (if (and (<= 2 (length a)) (andmap number? a)) | |
2804 | (apply = a) | |
2805 | (st:failure | |
2806 | (cons 'check-= ',id) | |
2807 | "invalid arguments: ~a" | |
2808 | a)))) | |
2809 | (defmacro | |
2810 | check-< | |
2811 | id | |
2812 | `(lambda a | |
2813 | (check-increment-counter ,(car id)) | |
2814 | (if (and (<= 2 (length a)) (andmap number? a)) | |
2815 | (apply < a) | |
2816 | (st:failure | |
2817 | (cons 'check-< ',id) | |
2818 | "invalid arguments: ~a" | |
2819 | a)))) | |
2820 | (defmacro | |
2821 | check-> | |
2822 | id | |
2823 | `(lambda a | |
2824 | (check-increment-counter ,(car id)) | |
2825 | (if (and (<= 2 (length a)) (andmap number? a)) | |
2826 | (apply > a) | |
2827 | (st:failure | |
2828 | (cons 'check-> ',id) | |
2829 | "invalid arguments: ~a" | |
2830 | a)))) | |
2831 | (defmacro | |
2832 | check-<= | |
2833 | id | |
2834 | `(lambda a | |
2835 | (check-increment-counter ,(car id)) | |
2836 | (if (and (<= 2 (length a)) (andmap number? a)) | |
2837 | (apply <= a) | |
2838 | (st:failure | |
2839 | (cons 'check-<= ',id) | |
2840 | "invalid arguments: ~a" | |
2841 | a)))) | |
2842 | (defmacro | |
2843 | check->= | |
2844 | id | |
2845 | `(lambda a | |
2846 | (check-increment-counter ,(car id)) | |
2847 | (if (and (<= 2 (length a)) (andmap number? a)) | |
2848 | (apply >= a) | |
2849 | (st:failure | |
2850 | (cons 'check->= ',id) | |
2851 | "invalid arguments: ~a" | |
2852 | 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?) | |
2858 | (defmacro | |
2859 | check-max | |
2860 | id | |
2861 | `(lambda a | |
2862 | (check-increment-counter ,(car id)) | |
2863 | (if (and (<= 1 (length a)) (andmap number? a)) | |
2864 | (apply max a) | |
2865 | (st:failure | |
2866 | (cons 'check-max ',id) | |
2867 | "invalid arguments: ~a" | |
2868 | a)))) | |
2869 | (defmacro | |
2870 | check-min | |
2871 | id | |
2872 | `(lambda a | |
2873 | (check-increment-counter ,(car id)) | |
2874 | (if (and (<= 1 (length a)) (andmap number? a)) | |
2875 | (apply min a) | |
2876 | (st:failure | |
2877 | (cons 'check-min ',id) | |
2878 | "invalid arguments: ~a" | |
2879 | a)))) | |
2880 | (defmacro | |
2881 | check-+ | |
2882 | id | |
2883 | `(lambda a | |
2884 | (check-increment-counter ,(car id)) | |
2885 | (if (andmap number? a) | |
2886 | (apply + a) | |
2887 | (st:failure | |
2888 | (cons 'check-+ ',id) | |
2889 | "invalid arguments: ~a" | |
2890 | a)))) | |
2891 | (defmacro | |
2892 | check-* | |
2893 | id | |
2894 | `(lambda a | |
2895 | (check-increment-counter ,(car id)) | |
2896 | (if (andmap number? a) | |
2897 | (apply * a) | |
2898 | (st:failure | |
2899 | (cons 'check-* ',id) | |
2900 | "invalid arguments: ~a" | |
2901 | a)))) | |
2902 | (defmacro | |
2903 | check-- | |
2904 | id | |
2905 | `(lambda a | |
2906 | (check-increment-counter ,(car id)) | |
2907 | (if (and (<= 1 (length a)) (andmap number? a)) | |
2908 | (apply - a) | |
2909 | (st:failure | |
2910 | (cons 'check-- ',id) | |
2911 | "invalid arguments: ~a" | |
2912 | a)))) | |
2913 | (defmacro | |
2914 | check-/ | |
2915 | id | |
2916 | `(lambda a | |
2917 | (check-increment-counter ,(car id)) | |
2918 | (if (and (<= 1 (length a)) (andmap number? a)) | |
2919 | (apply / a) | |
2920 | (st:failure | |
2921 | (cons 'check-/ ',id) | |
2922 | "invalid arguments: ~a" | |
2923 | 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?) | |
2928 | (defmacro | |
2929 | check-gcd | |
2930 | id | |
2931 | `(lambda a | |
2932 | (check-increment-counter ,(car id)) | |
2933 | (if (andmap number? a) | |
2934 | (apply gcd a) | |
2935 | (st:failure | |
2936 | (cons 'check-gcd ',id) | |
2937 | "invalid arguments: ~a" | |
2938 | a)))) | |
2939 | (defmacro | |
2940 | check-lcm | |
2941 | id | |
2942 | `(lambda a | |
2943 | (check-increment-counter ,(car id)) | |
2944 | (if (andmap number? a) | |
2945 | (apply lcm a) | |
2946 | (st:failure | |
2947 | (cons 'check-lcm ',id) | |
2948 | "invalid arguments: ~a" | |
2949 | 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?) | |
2964 | (defmacro | |
2965 | check-atan | |
2966 | id | |
2967 | `(lambda a | |
2968 | (check-increment-counter ,(car id)) | |
2969 | (if (and (andmap number? a) | |
2970 | (pair? a) | |
2971 | (>= 2 (length a))) | |
2972 | (apply atan a) | |
2973 | (st:failure | |
2974 | (cons 'check-atan ',id) | |
2975 | "invalid arguments: ~a" | |
2976 | a)))) | |
2977 | (make-check-typed sqrt number?) | |
2978 | (make-check-typed expt number? number?) | |
2979 | (make-check-typed | |
2980 | make-rectangular | |
2981 | number? | |
2982 | 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?) | |
2990 | (defmacro | |
2991 | check-number->string | |
2992 | id | |
2993 | `(lambda a | |
2994 | (check-increment-counter ,(car id)) | |
2995 | (if (and (andmap number? a) | |
2996 | (pair? a) | |
2997 | (>= 2 (length a))) | |
2998 | (apply number->string a) | |
2999 | (st:failure | |
3000 | (cons 'check-number->string ',id) | |
3001 | "invalid arguments: ~a" | |
3002 | a)))) | |
3003 | (defmacro | |
3004 | check-string->number | |
3005 | id | |
3006 | `(lambda a | |
3007 | (check-increment-counter ,(car id)) | |
3008 | (if (and (pair? a) | |
3009 | (string? (car a)) | |
3010 | (>= 2 (length a)) | |
3011 | (or (null? (cdr a)) (number? (cadr a)))) | |
3012 | (apply string->number a) | |
3013 | (st:failure | |
3014 | (cons 'check-string->number ',id) | |
3015 | "invalid arguments: ~a" | |
3016 | 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?) | |
3036 | (defmacro | |
3037 | check-make-string | |
3038 | id | |
3039 | `(lambda a | |
3040 | (check-increment-counter ,(car id)) | |
3041 | (if (and (pair? a) | |
3042 | (number? (car a)) | |
3043 | (>= 2 (length a)) | |
3044 | (or (null? (cdr a)) (char? (cadr a)))) | |
3045 | (apply make-string a) | |
3046 | (st:failure | |
3047 | (cons 'check-make-string ',id) | |
3048 | "invalid arguments: ~a" | |
3049 | a)))) | |
3050 | (defmacro | |
3051 | check-string | |
3052 | id | |
3053 | `(lambda a | |
3054 | (check-increment-counter ,(car id)) | |
3055 | (if (andmap char? a) | |
3056 | (apply string a) | |
3057 | (st:failure | |
3058 | (cons 'check-string ',id) | |
3059 | "invalid arguments: ~a" | |
3060 | a)))) | |
3061 | (make-check-typed string-length string?) | |
3062 | (make-check-typed string-ref string? number?) | |
3063 | (make-check-typed | |
3064 | string-set! | |
3065 | string? | |
3066 | number? | |
3067 | char?) | |
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?) | |
3078 | (make-check-typed | |
3079 | substring | |
3080 | string? | |
3081 | number? | |
3082 | number?) | |
3083 | (defmacro | |
3084 | check-string-append | |
3085 | id | |
3086 | `(lambda a | |
3087 | (check-increment-counter ,(car id)) | |
3088 | (if (andmap string? a) | |
3089 | (apply string-append a) | |
3090 | (st:failure | |
3091 | (cons 'check-string-append ',id) | |
3092 | "invalid arguments: ~a" | |
3093 | a)))) | |
3094 | (make-check-typed string->list string?) | |
3095 | (defmacro | |
3096 | check-list->string | |
3097 | id | |
3098 | `(lambda a | |
3099 | (check-increment-counter ,(car id)) | |
3100 | (if (and (= 1 (length a)) | |
3101 | (list? (car a)) | |
3102 | (andmap char? (car a))) | |
3103 | (list->string (car a)) | |
3104 | (st:failure | |
3105 | (cons 'check-list->string ',id) | |
3106 | "invalid arguments: ~a" | |
3107 | a)))) | |
3108 | (make-check-typed string-copy string?) | |
3109 | (make-check-typed string-fill! string? char?) | |
3110 | (make-check-typed make-vector number? _) | |
3111 | (defmacro | |
3112 | check-vector | |
3113 | id | |
3114 | `(lambda a | |
3115 | (check-increment-counter ,(car id)) | |
3116 | (apply vector a))) | |
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? _) | |
3123 | (defmacro | |
3124 | check-apply | |
3125 | id | |
3126 | `(lambda a | |
3127 | (check-increment-counter ,(car id)) | |
3128 | (if (pair? a) | |
3129 | (let loop ((arg (cdr a))) | |
3130 | (match arg | |
3131 | (((? list?)) (apply apply a)) | |
3132 | ((_ . y) (loop y)) | |
3133 | (_ (st:failure | |
3134 | (cons 'check-apply ',id) | |
3135 | "invalid arguments: ~a" | |
3136 | a)))) | |
3137 | (st:failure | |
3138 | `(check-apply ,@id) | |
3139 | "invalid arguments: ~a" | |
3140 | a)))) | |
3141 | (defmacro | |
3142 | check-map | |
3143 | id | |
3144 | `(lambda a | |
3145 | (check-increment-counter ,(car id)) | |
3146 | (if (and (<= 2 (length a)) | |
3147 | (procedure? (car a)) | |
3148 | (andmap list? (cdr a))) | |
3149 | (apply map a) | |
3150 | (st:failure | |
3151 | (cons 'check-map ',id) | |
3152 | "invalid arguments: ~a" | |
3153 | a)))) | |
3154 | (defmacro | |
3155 | check-for-each | |
3156 | id | |
3157 | `(lambda a | |
3158 | (check-increment-counter ,(car id)) | |
3159 | (if (and (<= 2 (length a)) | |
3160 | (procedure? (car a)) | |
3161 | (andmap list? (cdr a))) | |
3162 | (apply for-each a) | |
3163 | (st:failure | |
3164 | (cons 'check-for-each ',id) | |
3165 | "invalid arguments: ~a" | |
3166 | a)))) | |
3167 | (make-check-typed force procedure?) | |
3168 | (defmacro | |
3169 | check-call-with-current-continuation | |
3170 | id | |
3171 | `(lambda a | |
3172 | (check-increment-counter ,(car id)) | |
3173 | (if (and (= 1 (length a)) (procedure? (car a))) | |
3174 | (call-with-current-continuation | |
3175 | (lambda (k) | |
3176 | ((car a) (check-lambda (continuation) (x) (k x))))) | |
3177 | (st:failure | |
3178 | (cons 'check-call-with-current-continuation ',id) | |
3179 | "invalid arguments: ~a" | |
3180 | a)))) | |
3181 | (make-check-typed | |
3182 | call-with-input-file | |
3183 | string? | |
3184 | procedure?) | |
3185 | (make-check-typed | |
3186 | call-with-output-file | |
3187 | string? | |
3188 | procedure?) | |
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) | |
3193 | (make-check-typed | |
3194 | with-input-from-file | |
3195 | string? | |
3196 | procedure?) | |
3197 | (make-check-typed | |
3198 | with-output-to-file | |
3199 | string? | |
3200 | procedure?) | |
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?) | |
3205 | (defmacro | |
3206 | check-read | |
3207 | id | |
3208 | `(lambda a | |
3209 | (check-increment-counter ,(car id)) | |
3210 | (if (or (null? a) | |
3211 | (and (= 1 (length a)) (input-port? (car a)))) | |
3212 | (apply read a) | |
3213 | (st:failure | |
3214 | (cons 'check-read ',id) | |
3215 | "invalid arguments: ~a" | |
3216 | a)))) | |
3217 | (defmacro | |
3218 | check-read-char | |
3219 | id | |
3220 | `(lambda a | |
3221 | (check-increment-counter ,(car id)) | |
3222 | (if (or (null? a) | |
3223 | (and (= 1 (length a)) (input-port? (car a)))) | |
3224 | (apply read-char a) | |
3225 | (st:failure | |
3226 | (cons 'check-read-char ',id) | |
3227 | "invalid arguments: ~a" | |
3228 | a)))) | |
3229 | (defmacro | |
3230 | check-peek-char | |
3231 | id | |
3232 | `(lambda a | |
3233 | (check-increment-counter ,(car id)) | |
3234 | (if (or (null? a) | |
3235 | (and (= 1 (length a)) (input-port? (car a)))) | |
3236 | (apply peek-char a) | |
3237 | (st:failure | |
3238 | (cons 'check-peek-char ',id) | |
3239 | "invalid arguments: ~a" | |
3240 | a)))) | |
3241 | (defmacro | |
3242 | check-char-ready? | |
3243 | id | |
3244 | `(lambda a | |
3245 | (check-increment-counter ,(car id)) | |
3246 | (if (or (null? a) | |
3247 | (and (= 1 (length a)) (input-port? (car a)))) | |
3248 | (apply char-ready? a) | |
3249 | (st:failure | |
3250 | (cons 'check-char-ready? ',id) | |
3251 | "invalid arguments: ~a" | |
3252 | a)))) | |
3253 | (defmacro | |
3254 | check-write | |
3255 | id | |
3256 | `(lambda a | |
3257 | (check-increment-counter ,(car id)) | |
3258 | (if (and (pair? a) | |
3259 | (or (null? (cdr a)) (output-port? (cadr a)))) | |
3260 | (apply write a) | |
3261 | (st:failure | |
3262 | (cons 'check-write ',id) | |
3263 | "invalid arguments: ~a" | |
3264 | a)))) | |
3265 | (defmacro | |
3266 | check-display | |
3267 | id | |
3268 | `(lambda a | |
3269 | (check-increment-counter ,(car id)) | |
3270 | (if (and (pair? a) | |
3271 | (or (null? (cdr a)) (output-port? (cadr a)))) | |
3272 | (apply display a) | |
3273 | (st:failure | |
3274 | (cons 'check-display ',id) | |
3275 | "invalid arguments: ~a" | |
3276 | a)))) | |
3277 | (defmacro | |
3278 | check-newline | |
3279 | id | |
3280 | `(lambda a | |
3281 | (check-increment-counter ,(car id)) | |
3282 | (if (or (null? a) (output-port? (car a))) | |
3283 | (apply newline a) | |
3284 | (st:failure | |
3285 | (cons 'check-newline ',id) | |
3286 | "invalid arguments: ~a" | |
3287 | a)))) | |
3288 | (defmacro | |
3289 | check-write-char | |
3290 | id | |
3291 | `(lambda a | |
3292 | (check-increment-counter ,(car id)) | |
3293 | (if (and (pair? a) | |
3294 | (char? (car a)) | |
3295 | (or (null? (cdr a)) (output-port? (cadr a)))) | |
3296 | (apply write-char a) | |
3297 | (st:failure | |
3298 | (cons 'check-write-char ',id) | |
3299 | "invalid arguments: ~a" | |
3300 | a)))) | |
3301 | (make-check-typed load string?) | |
3302 | (make-check-typed transcript-on string?) | |
3303 | (make-check-typed transcript-off) | |
3304 | (defmacro | |
3305 | check-symbol-append | |
3306 | id | |
3307 | `(lambda a | |
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 _) | |
3315 | (defmacro | |
3316 | check-match:error | |
3317 | id | |
3318 | `(lambda a | |
3319 | (check-increment-counter ,(car id)) | |
3320 | (if (pair? a) | |
3321 | (apply match:error a) | |
3322 | (st:failure | |
3323 | (cons 'check-match:error ',id) | |
3324 | "invalid arguments: ~a" | |
3325 | a)))) | |
3326 | (make-check-typed should-never-reach symbol?) | |
3327 | (defmacro | |
3328 | check-make-cvector | |
3329 | id | |
3330 | `(lambda a | |
3331 | (check-increment-counter ,(car id)) | |
3332 | (if (and (pair? a) | |
3333 | (number? (car a)) | |
3334 | (= 2 (length a))) | |
3335 | (apply make-cvector a) | |
3336 | (st:failure | |
3337 | (cons 'check-make-cvector ',id) | |
3338 | "invalid arguments: ~a" | |
3339 | a)))) | |
3340 | (defmacro | |
3341 | check-cvector | |
3342 | id | |
3343 | `(lambda a | |
3344 | (check-increment-counter ,(car id)) | |
3345 | (apply cvector a))) | |
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?) | |
3350 | (defmacro | |
3351 | check-define-const-structure | |
3352 | args | |
3353 | (let ((field? | |
3354 | (lambda (x) | |
3355 | (or (symbol? x) | |
3356 | (and (pair? x) | |
3357 | (equal? (car x) '!) | |
3358 | (pair? (cdr x)) | |
3359 | (symbol? (cadr x)) | |
3360 | (null? (cddr x)))))) | |
3361 | (arg-name | |
3362 | (lambda (x) (if (symbol? x) x (cadr x)))) | |
3363 | (with-mutator? (lambda (x) (not (symbol? x))))) | |
3364 | (match args | |
3365 | ((((? symbol? name) (? field? id1) ...)) | |
3366 | (let ((constructor (symbol-append 'make- name)) | |
3367 | (check-constructor | |
3368 | (symbol-append 'check-make- name)) | |
3369 | (predicate (symbol-append name '?)) | |
3370 | (access | |
3371 | (let loop ((l id1)) | |
3372 | (cond ((null? l) '()) | |
3373 | ((eq? '_ (arg-name (car l))) (loop (cdr l))) | |
3374 | (else | |
3375 | (cons (symbol-append name '- (arg-name (car l))) | |
3376 | (loop (cdr l))))))) | |
3377 | (assign | |
3378 | (let loop ((l id1)) | |
3379 | (cond ((null? l) '()) | |
3380 | ((eq? '_ (arg-name (car l))) (loop (cdr l))) | |
3381 | ((not (with-mutator? (car l))) (loop (cdr l))) | |
3382 | (else | |
3383 | (cons (symbol-append | |
3384 | 'set- | |
3385 | name | |
3386 | '- | |
3387 | (arg-name (car l)) | |
3388 | '!) | |
3389 | (loop (cdr l))))))) | |
3390 | (nargs (length id1))) | |
3391 | `(begin | |
3392 | (define-const-structure (,name ,@id1) ()) | |
3393 | (defmacro | |
3394 | ,check-constructor | |
3395 | id | |
3396 | (lambda a | |
3397 | (check-increment-counter (,'unquote (car id))) | |
3398 | (if (= ,nargs (length a)) | |
3399 | (apply ,constructor a) | |
3400 | (st:failure | |
3401 | (cons ',check-constructor '(,'unquote id)) | |
3402 | "invalid arguments: ~a" | |
3403 | a)))) | |
3404 | (make-check-typed ,predicate _) | |
3405 | ,@(map (lambda (a) `(make-check-typed ,a ,predicate)) | |
3406 | access) | |
3407 | ,@(map (lambda (a) `(make-check-typed ,a ,predicate _)) | |
3408 | assign)))) | |
3409 | (x (st:failure | |
3410 | `(check-define-const-structure ,@x) | |
3411 | "syntax error"))))) | |
3412 | (if (equal? '(match 1) (macroexpand-1 '(match 1))) | |
3413 | (load "/home/wright/scheme/match/match-slib.scm")) | |
3414 | (define sprintf | |
3415 | (lambda args (apply format #f args))) | |
3416 | (define printf | |
3417 | (lambda args (apply format #t args))) | |
3418 | (define disaster | |
3419 | (lambda (context fmt . args) | |
3420 | (slib:error | |
3421 | (apply sprintf | |
3422 | (string-append "in ~a: " fmt) | |
3423 | context | |
3424 | args)))) | |
3425 | (define use-error | |
3426 | (lambda (fmt . args) | |
3427 | (slib:error (apply sprintf fmt args)))) | |
3428 | (define syntax-err | |
3429 | (lambda (context fmt . args) | |
3430 | (newline) | |
3431 | (if context (pretty-print context)) | |
3432 | (slib:error | |
3433 | (apply sprintf | |
3434 | (string-append "in syntax: " fmt) | |
3435 | args)))) | |
3436 | (define flush-output force-output) | |
3437 | (define print-context | |
3438 | (lambda (obj depth) | |
3439 | (pretty-print | |
3440 | (recur loop | |
3441 | ((obj obj) (n 0)) | |
3442 | (if (pair? obj) | |
3443 | (if (< n depth) | |
3444 | (cons (loop (car obj) (+ 1 n)) | |
3445 | (loop (cdr obj) n)) | |
3446 | '(...)) | |
3447 | obj))))) | |
3448 | (define *box-tag* (gensym)) | |
3449 | (define box (lambda (a) (cons *box-tag* a))) | |
3450 | (define box? | |
3451 | (lambda (b) | |
3452 | (and (pair? b) (eq? (car b) *box-tag*)))) | |
3453 | (define unbox cdr) | |
3454 | (define box-1 cdr) | |
3455 | (define set-box! set-cdr!) | |
3456 | (define sort-list sort) | |
3457 | (define expand-once-if-macro | |
3458 | (lambda (e) | |
3459 | (and (macro? (car e)) (macroexpand-1 e)))) | |
3460 | (define ormap | |
3461 | (lambda (f . lists) | |
3462 | (if (null? (car lists)) | |
3463 | (or) | |
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!) | |
3472 | (define maplr | |
3473 | (lambda (f l) | |
3474 | (match l | |
3475 | (() '()) | |
3476 | ((x . y) (let ((v (f x))) (cons v (maplr f y))))))) | |
3477 | (define maprl | |
3478 | (lambda (f l) | |
3479 | (match l | |
3480 | (() '()) | |
3481 | ((x . y) (let ((v (maprl f y))) (cons (f x) v)))))) | |
3482 | (define foldl | |
3483 | (lambda (f i l) | |
3484 | (recur loop | |
3485 | ((l l) (acc i)) | |
3486 | (match l (() acc) ((x . y) (loop y (f x acc))))))) | |
3487 | (define foldr | |
3488 | (lambda (f i l) | |
3489 | (recur loop | |
3490 | ((l l)) | |
3491 | (match l (() i) ((x . y) (f x (loop y))))))) | |
3492 | (define filter | |
3493 | (lambda (p l) | |
3494 | (match l | |
3495 | (() '()) | |
3496 | ((x . y) | |
3497 | (if (p x) (cons x (filter p y)) (filter p y)))))) | |
3498 | (define filter-map | |
3499 | (lambda (p l) | |
3500 | (match l | |
3501 | (() '()) | |
3502 | ((x . y) | |
3503 | (match (p x) | |
3504 | (#f (filter-map p y)) | |
3505 | (x (cons x (filter-map p y)))))))) | |
3506 | (define rac | |
3507 | (lambda (l) | |
3508 | (match l ((last) last) ((_ . rest) (rac rest))))) | |
3509 | (define rdc | |
3510 | (lambda (l) | |
3511 | (match l | |
3512 | ((_) '()) | |
3513 | ((x . rest) (cons x (rdc rest)))))) | |
3514 | (define map-with-n | |
3515 | (lambda (f l) | |
3516 | (recur loop | |
3517 | ((l l) (n 0)) | |
3518 | (match l | |
3519 | (() '()) | |
3520 | ((x . y) | |
3521 | (let ((v (f x n))) (cons v (loop y (+ 1 n))))))))) | |
3522 | (define readfile | |
3523 | (lambda (f) | |
3524 | (with-input-from-file | |
3525 | f | |
3526 | (letrec ((rf (lambda () | |
3527 | (match (read) | |
3528 | ((? eof-object?) '()) | |
3529 | (sexp (cons sexp (rf))))))) | |
3530 | rf)))) | |
3531 | (define map2 | |
3532 | (lambda (f a b) | |
3533 | (match (cons a b) | |
3534 | ((()) '()) | |
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"))))) | |
3538 | (define for-each2 | |
3539 | (lambda (f a b) | |
3540 | (match (cons a b) | |
3541 | ((()) (void)) | |
3542 | (((ax . ay) bx . by) | |
3543 | (f ax bx) | |
3544 | (for-each2 f ay by)) | |
3545 | (else (error 'for-each2 "lists differ in length"))))) | |
3546 | (define andmap2 | |
3547 | (lambda (f a b) | |
3548 | (match (cons a b) | |
3549 | ((()) (and)) | |
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"))))) | |
3554 | (define ormap2 | |
3555 | (lambda (f a b) | |
3556 | (match (cons a b) | |
3557 | ((()) (or)) | |
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))) | |
3565 | (define list->set | |
3566 | (match-lambda | |
3567 | (() '()) | |
3568 | ((x . y) | |
3569 | (if (memq x y) | |
3570 | (list->set y) | |
3571 | (cons x (list->set y)))))) | |
3572 | (define element-of? | |
3573 | (lambda (x set) (and (memq x set) #t))) | |
3574 | (define cardinality length) | |
3575 | (define set<= | |
3576 | (lambda (a b) | |
3577 | (foldr (lambda (a-elt acc) (and acc (memq a-elt b) #t)) | |
3578 | (and) | |
3579 | a))) | |
3580 | (define set-eq? | |
3581 | (lambda (a b) | |
3582 | (and (= (cardinality a) (cardinality b)) | |
3583 | (set<= a b)))) | |
3584 | (define union2 | |
3585 | (lambda (a b) | |
3586 | (if (null? b) | |
3587 | a | |
3588 | (foldr (lambda (x b) (if (memq x b) b (cons x b))) | |
3589 | b | |
3590 | a)))) | |
3591 | (define union (lambda l (foldr union2 '() l))) | |
3592 | (define setdiff2 | |
3593 | (lambda (a b) | |
3594 | (if (null? b) | |
3595 | a | |
3596 | (foldr (lambda (x c) (if (memq x b) c (cons x c))) | |
3597 | '() | |
3598 | a)))) | |
3599 | (define setdiff | |
3600 | (lambda l | |
3601 | (if (null? l) | |
3602 | '() | |
3603 | (setdiff2 (car l) (foldr union2 '() (cdr l)))))) | |
3604 | (define intersect2 | |
3605 | (lambda (a b) | |
3606 | (if (null? b) | |
3607 | a | |
3608 | (foldr (lambda (x c) (if (memq x b) (cons x c) c)) | |
3609 | '() | |
3610 | a)))) | |
3611 | (define intersect | |
3612 | (lambda l | |
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 | |
3650 | (defstruct | |
3651 | tag | |
3652 | args | |
3653 | make | |
3654 | pred | |
3655 | get | |
3656 | set | |
3657 | getn | |
3658 | setn | |
3659 | mutable)) | |
3660 | (define-const-structure (datatype _)) | |
3661 | (define-const-structure | |
3662 | (variant con pred arg-types)) | |
3663 | (define-structure | |
3664 | (name name | |
3665 | ty | |
3666 | timestamp | |
3667 | occ | |
3668 | mutated | |
3669 | gdef | |
3670 | primitive | |
3671 | struct | |
3672 | pure | |
3673 | predicate | |
3674 | variant | |
3675 | selector)) | |
3676 | (define-structure (type ty exp)) | |
3677 | (define-const-structure (shape _ _)) | |
3678 | (define-const-structure (check _ _)) | |
3679 | (define parse-def | |
3680 | (lambda (def) | |
3681 | (let ((parse-name | |
3682 | (match-lambda | |
3683 | ((? symbol? s) | |
3684 | (if (keyword? s) | |
3685 | (syntax-err def "invalid use of keyword ~a" s) | |
3686 | s)) | |
3687 | (n (syntax-err def "invalid variable at ~a" n))))) | |
3688 | (match def | |
3689 | (('extend-syntax ((? symbol? name) . _) . _) | |
3690 | (printf | |
3691 | "Note: installing but _not_ checking (extend-syntax (~a) ...)~%" | |
3692 | name) | |
3693 | (eval def) | |
3694 | '()) | |
3695 | (('extend-syntax . _) | |
3696 | (syntax-err def "invalid syntax")) | |
3697 | (('defmacro (? symbol? name) . _) | |
3698 | (printf | |
3699 | "Note: installing but _not_ checking (defmacro ~a ...)~%" | |
3700 | name) | |
3701 | (eval def) | |
3702 | '()) | |
3703 | (('defmacro . _) | |
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) | |
3708 | (list (make-define | |
3709 | (parse-name n) | |
3710 | (parse-exp `(lambda ,args ,@body))))) | |
3711 | (('define . _) (syntax-err def "at define")) | |
3712 | (('begin . defs) | |
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)) | |
3718 | (m-inits | |
3719 | (smap (match-lambda | |
3720 | ((x e) `((! ,x) ,e)) | |
3721 | (_ (syntax-err | |
3722 | def | |
3723 | "invalid structure initializer"))) | |
3724 | inits))) | |
3725 | (parse-def | |
3726 | `(define-const-structure (,n ,@m-args) ,m-inits)))) | |
3727 | (('define-const-structure ((? symbol? n) . args)) | |
3728 | (parse-def | |
3729 | `(define-const-structure (,n ,@args) ()))) | |
3730 | (('define-const-structure | |
3731 | ((? symbol? n) . args) | |
3732 | ()) | |
3733 | (letrec ((smap-with-n | |
3734 | (lambda (f l) | |
3735 | (recur loop | |
3736 | ((l l) (n 0)) | |
3737 | (match l | |
3738 | (() '()) | |
3739 | ((x . y) | |
3740 | (let ((v (f x n))) | |
3741 | (cons v (loop y (+ 1 n))))) | |
3742 | (_ (syntax-err l "invalid list")))))) | |
3743 | (parse-arg | |
3744 | (lambda (a index) | |
3745 | (match a | |
3746 | (('! '_) | |
3747 | (list none | |
3748 | none | |
3749 | (some (symbol-append | |
3750 | n | |
3751 | '- | |
3752 | (+ index 1))) | |
3753 | (some (symbol-append | |
3754 | 'set- | |
3755 | n | |
3756 | '- | |
3757 | (+ index 1) | |
3758 | '!)) | |
3759 | #t)) | |
3760 | (('! a) | |
3761 | (let ((a (parse-name a))) | |
3762 | (list (some (symbol-append n '- a)) | |
3763 | (some (symbol-append | |
3764 | 'set- | |
3765 | n | |
3766 | '- | |
3767 | a | |
3768 | '!)) | |
3769 | (some (symbol-append | |
3770 | n | |
3771 | '- | |
3772 | (+ index 1))) | |
3773 | (some (symbol-append | |
3774 | 'set- | |
3775 | n | |
3776 | '- | |
3777 | (+ index 1) | |
3778 | '!)) | |
3779 | #t))) | |
3780 | ('_ | |
3781 | (list none | |
3782 | none | |
3783 | (some (symbol-append | |
3784 | n | |
3785 | '- | |
3786 | (+ index 1))) | |
3787 | none | |
3788 | #f)) | |
3789 | (a (let ((a (parse-name a))) | |
3790 | (list (some (symbol-append n '- a)) | |
3791 | none | |
3792 | (some (symbol-append | |
3793 | n | |
3794 | '- | |
3795 | (+ index 1))) | |
3796 | none | |
3797 | #f))))))) | |
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)) | |
3803 | (mutable | |
3804 | (map (lambda (x) (car (cddddr x))) arg-info))) | |
3805 | (list (make-defstruct | |
3806 | n | |
3807 | (cons n args) | |
3808 | (symbol-append 'make- n) | |
3809 | (symbol-append n '?) | |
3810 | get | |
3811 | set | |
3812 | getn | |
3813 | setn | |
3814 | mutable))))) | |
3815 | (('define-const-structure | |
3816 | ((? symbol? n) . args) | |
3817 | inits) | |
3818 | (syntax-err | |
3819 | def | |
3820 | "sorry, structure initializers are not supported")) | |
3821 | (('datatype . d) | |
3822 | (let* ((parse-variant | |
3823 | (match-lambda | |
3824 | (((? symbol? con) ? list? args) | |
3825 | (let ((n (parse-name con))) | |
3826 | (make-variant | |
3827 | (symbol-append 'make- n) | |
3828 | (symbol-append n '?) | |
3829 | (cons con args)))) | |
3830 | (_ (syntax-err def "invalid datatype syntax")))) | |
3831 | (parse-dt | |
3832 | (match-lambda | |
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)) | |
3845 | => | |
3846 | parse-def) | |
3847 | (else (list (make-define #f (parse-exp def)))))) | |
3848 | (_ (list (make-define #f (parse-exp def)))))))) | |
3849 | (define keep-match #t) | |
3850 | (define parse-exp | |
3851 | (lambda (expression) | |
3852 | (letrec ((n-primitive (string->symbol "#primitive")) | |
3853 | (parse-exp | |
3854 | (match-lambda | |
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)) | |
3879 | (=> fail) | |
3880 | (if keep-match | |
3881 | (let* ((e2 (parse-exp e)) | |
3882 | (parse-clause | |
3883 | (match-lambda | |
3884 | ((p ('=> (? symbol? failsym)) . body) | |
3885 | (make-mclause | |
3886 | (parse-pat p expression) | |
3887 | (parse-body | |
3888 | `((let ((,failsym (lambda () (,failsym)))) | |
3889 | ,@body))) | |
3890 | failsym)) | |
3891 | ((p . body) | |
3892 | (make-mclause | |
3893 | (parse-pat p expression) | |
3894 | (parse-body body) | |
3895 | #f)) | |
3896 | (_ (syntax-err exp "invalid match clause"))))) | |
3897 | (make-match | |
3898 | e2 | |
3899 | (smap parse-clause (cons clause0 clauses)))) | |
3900 | (fail))) | |
3901 | ((and exp ('lambda bind . body)) | |
3902 | (recur loop | |
3903 | ((b bind) (names '())) | |
3904 | (match b | |
3905 | ((? symbol? n) | |
3906 | (let ((rest (parse-name n))) | |
3907 | (no-repeats (cons rest names) exp) | |
3908 | (make-vlam | |
3909 | (reverse names) | |
3910 | rest | |
3911 | (parse-body body)))) | |
3912 | (() | |
3913 | (no-repeats names exp) | |
3914 | (make-lam (reverse names) (parse-body body))) | |
3915 | ((n . x) (loop x (cons (parse-name n) names))) | |
3916 | (_ (syntax-err | |
3917 | exp | |
3918 | "invalid lambda expression"))))) | |
3919 | (('if e1 e2 e3) | |
3920 | (make-if | |
3921 | (parse-exp e1) | |
3922 | (parse-exp e2) | |
3923 | (parse-exp e3))) | |
3924 | ((and if-expr ('if e1 e2)) | |
3925 | (printf "Note: one-armed if: ") | |
3926 | (print-context if-expr 2) | |
3927 | (make-if | |
3928 | (parse-exp e1) | |
3929 | (parse-exp e2) | |
3930 | (parse-exp '(void)))) | |
3931 | (('delay e) (make-delay (parse-exp e))) | |
3932 | (('set! n 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) | |
3940 | (make-app | |
3941 | (make-letr | |
3942 | (list (make-bind | |
3943 | nb | |
3944 | (make-lam | |
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) | |
3954 | (make-let* | |
3955 | (smap parse-bind bind) | |
3956 | (parse-body body))) | |
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)))) | |
3961 | (('begin e1 . rest) | |
3962 | (make-begin (smap parse-exp (cons e1 rest)))) | |
3963 | (('define . _) | |
3964 | (syntax-err | |
3965 | expression | |
3966 | "invalid context for internal define")) | |
3967 | (('define-structure . _) | |
3968 | (syntax-err | |
3969 | expression | |
3970 | "invalid context for internal define-structure")) | |
3971 | (('define-const-structure . _) | |
3972 | (syntax-err | |
3973 | expression | |
3974 | "invalid context for internal define-const-structure")) | |
3975 | ((and m (f . args)) | |
3976 | (cond ((and (eq? f n-primitive) | |
3977 | (match args | |
3978 | (((? symbol? p)) (make-prim p)) | |
3979 | (_ #f)))) | |
3980 | ((and (symbol? f) | |
3981 | (not (keyword? f)) | |
3982 | (expand-once-if-macro m)) | |
3983 | => | |
3984 | parse-exp) | |
3985 | (else | |
3986 | (make-app (parse-exp f) (smap parse-exp args))))) | |
3987 | (x (syntax-err | |
3988 | expression | |
3989 | "invalid expression at ~a" | |
3990 | x)))) | |
3991 | (parse-name | |
3992 | (match-lambda | |
3993 | ((? symbol? s) | |
3994 | (when (keyword? s) | |
3995 | (syntax-err | |
3996 | expression | |
3997 | "invalid use of keyword ~a" | |
3998 | s)) | |
3999 | s) | |
4000 | (n (syntax-err | |
4001 | expression | |
4002 | "invalid variable at ~a" | |
4003 | n)))) | |
4004 | (parse-bind | |
4005 | (match-lambda | |
4006 | ((x e) (make-bind (parse-name x) (parse-exp e))) | |
4007 | (b (syntax-err expression "invalid binding at ~a" b)))) | |
4008 | (parse-body | |
4009 | (lambda (body) | |
4010 | (recur loop | |
4011 | ((b body) (defs '())) | |
4012 | (match b | |
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 . _) . _)) | |
4023 | . | |
4024 | rest) | |
4025 | (loop rest (append defs (parse-def beg)))) | |
4026 | (((and beg | |
4027 | ('begin | |
4028 | ('define-const-structure . _) | |
4029 | . | |
4030 | _)) | |
4031 | . | |
4032 | rest) | |
4033 | (loop rest (append defs (parse-def beg)))) | |
4034 | ((_ . _) (make-body defs (smap parse-exp b))) | |
4035 | (_ (syntax-err | |
4036 | expression | |
4037 | "invalid body at ~a" | |
4038 | b)))))) | |
4039 | (no-repeats | |
4040 | (lambda (l exp) | |
4041 | (match l | |
4042 | (() #f) | |
4043 | ((_) #f) | |
4044 | ((x . l) | |
4045 | (if (memq x l) | |
4046 | (syntax-err exp "name ~a repeated" x) | |
4047 | (no-repeats l exp))))))) | |
4048 | (parse-exp expression)))) | |
4049 | (define parse-pat | |
4050 | (lambda (pat expression) | |
4051 | (letrec ((parse-pat | |
4052 | (match-lambda | |
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)) | |
4060 | ('_ (make-pany)) | |
4061 | ('else (make-pelse)) | |
4062 | ((? symbol? n) (make-pvar (parse-pname n))) | |
4063 | (('not . pats) | |
4064 | (syntax-err | |
4065 | expression | |
4066 | "not patterns are not supported")) | |
4067 | (('or . pats) | |
4068 | (syntax-err | |
4069 | expression | |
4070 | "or patterns are not supported")) | |
4071 | (('get! . pats) | |
4072 | (syntax-err | |
4073 | expression | |
4074 | "get! patterns are not supported")) | |
4075 | (('set! . pats) | |
4076 | (syntax-err | |
4077 | expression | |
4078 | "set! patterns are not supported")) | |
4079 | (('and . pats) | |
4080 | (let* ((pats (smap parse-pat pats)) | |
4081 | (p (make-flat-pand pats)) | |
4082 | (non-var? | |
4083 | (match-lambda | |
4084 | ((? pvar?) #f) | |
4085 | ((? pany?) #f) | |
4086 | (_ #t)))) | |
4087 | (match p | |
4088 | (($ pand pats) | |
4089 | (when (< 1 (length (filter non-var? pats))) | |
4090 | (syntax-err | |
4091 | expression | |
4092 | "~a has conflicting subpatterns" | |
4093 | (ppat p)))) | |
4094 | (_ #f)) | |
4095 | p)) | |
4096 | (('? (? symbol? pred) p) | |
4097 | (parse-pat `(and (? ,pred) ,p))) | |
4098 | (('? (? symbol? pred)) | |
4099 | (if (keyword? pred) | |
4100 | (syntax-err | |
4101 | expression | |
4102 | "invalid use of keyword ~a" | |
4103 | pred) | |
4104 | (make-ppred pred))) | |
4105 | (('$ (? symbol? c) . args) | |
4106 | (if (memq c '(? _ $)) | |
4107 | (syntax-err | |
4108 | expression | |
4109 | "invalid use of pattern keyword ~a" | |
4110 | c) | |
4111 | (make-pobj | |
4112 | (symbol-append c '?) | |
4113 | (smap parse-pat args)))) | |
4114 | ((? box? cb) | |
4115 | (make-pobj 'box? (list (parse-pat (unbox cb))))) | |
4116 | ((x . y) | |
4117 | (make-pobj | |
4118 | 'pair? | |
4119 | (list (parse-pat x) (parse-pat y)))) | |
4120 | ((? vector? v) | |
4121 | (make-pobj | |
4122 | 'vector? | |
4123 | (map parse-pat (vector->list v)))) | |
4124 | (m (syntax-err expression "invalid pattern at ~a" m)))) | |
4125 | (parse-quote | |
4126 | (match-lambda | |
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?)) | |
4134 | ((? box? cb) | |
4135 | (make-pobj 'box? (list (parse-quote (unbox cb))))) | |
4136 | ((x . y) | |
4137 | (make-pobj | |
4138 | 'pair? | |
4139 | (list (parse-quote x) (parse-quote y)))) | |
4140 | ((? vector? v) | |
4141 | (make-pobj | |
4142 | 'vector? | |
4143 | (map parse-quote (vector->list v)))) | |
4144 | (m (syntax-err expression "invalid pattern at ~a" m)))) | |
4145 | (parse-pname | |
4146 | (match-lambda | |
4147 | ((? symbol? s) | |
4148 | (cond ((keyword? s) | |
4149 | (syntax-err | |
4150 | expression | |
4151 | "invalid use of keyword ~a" | |
4152 | s)) | |
4153 | ((memq s '(? _ else $ and or not set! get! ...)) | |
4154 | (syntax-err | |
4155 | expression | |
4156 | "invalid use of pattern keyword ~a" | |
4157 | s)) | |
4158 | (else s))) | |
4159 | (n (syntax-err | |
4160 | expression | |
4161 | "invalid pattern variable at ~a" | |
4162 | n))))) | |
4163 | (parse-pat pat)))) | |
4164 | (define smap | |
4165 | (lambda (f l) | |
4166 | (match l | |
4167 | (() '()) | |
4168 | ((x . r) (let ((v (f x))) (cons v (smap f r)))) | |
4169 | (_ (syntax-err l "invalid list"))))) | |
4170 | (define primitive | |
4171 | (lambda (p) | |
4172 | (list (string->symbol "#primitive") p))) | |
4173 | (define keyword? | |
4174 | (lambda (s) | |
4175 | (or (memq s | |
4176 | '(=> and | |
4177 | begin | |
4178 | case | |
4179 | cond | |
4180 | do | |
4181 | define | |
4182 | delay | |
4183 | if | |
4184 | lambda | |
4185 | let | |
4186 | let* | |
4187 | letrec | |
4188 | or | |
4189 | quasiquote | |
4190 | quote | |
4191 | set! | |
4192 | unquote | |
4193 | unquote-splicing | |
4194 | define-structure | |
4195 | define-const-structure | |
4196 | record | |
4197 | field | |
4198 | : | |
4199 | datatype)) | |
4200 | (and keep-match (eq? s 'match))))) | |
4201 | (define make-flat-pand | |
4202 | (lambda (pats) | |
4203 | (let* ((l (foldr (lambda (p plist) | |
4204 | (match p | |
4205 | (($ pand pats) (append pats plist)) | |
4206 | (_ (cons p plist)))) | |
4207 | '() | |
4208 | pats)) | |
4209 | (concrete? | |
4210 | (match-lambda | |
4211 | ((? pconst?) #t) | |
4212 | ((? pobj?) #t) | |
4213 | ((? ppred?) #t) | |
4214 | (_ #f))) | |
4215 | (sorted | |
4216 | (append | |
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))) | |
4223 | (define cond-tf | |
4224 | (lambda (cond-expr) | |
4225 | (recur loop | |
4226 | ((e (cdr cond-expr))) | |
4227 | (match e | |
4228 | (() | |
4229 | (begin | |
4230 | (set! never-counter (+ 1 never-counter)) | |
4231 | `(,(primitive 'should-never-reach) | |
4232 | '(cond ,never-counter)))) | |
4233 | ((('else b1 . body)) `(begin ,b1 ,@body)) | |
4234 | ((('else . _) . _) | |
4235 | (syntax-err cond-expr "invalid cond expression")) | |
4236 | (((test '=> proc) . rest) | |
4237 | (let ((g (gensym))) | |
4238 | `(let ((,g ,test)) | |
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 | |
4246 | (lambda (cond-expr) | |
4247 | (recur loop | |
4248 | ((e (cdr cond-expr))) | |
4249 | (match e | |
4250 | (() `(,(primitive 'void))) | |
4251 | ((('else b1 . body)) `(begin ,b1 ,@body)) | |
4252 | ((('else . _) . _) | |
4253 | (syntax-err cond-expr "invalid cond expression")) | |
4254 | (((test '=> proc) . rest) | |
4255 | (let ((g (gensym))) | |
4256 | `(let ((,g ,test)) | |
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")))))) | |
4263 | (define case-tf | |
4264 | (lambda (case-expr) | |
4265 | (recur loop | |
4266 | ((e (cdr case-expr))) | |
4267 | (match e | |
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")) | |
4272 | (((? symbol? exp) | |
4273 | ((? list? test) b1 . body) | |
4274 | . | |
4275 | rest) | |
4276 | `(if (,(primitive 'memv) ,exp ',test) | |
4277 | (begin ,b1 ,@body) | |
4278 | ,(loop (cons exp rest)))) | |
4279 | (((? symbol? exp) (test b1 . body) . rest) | |
4280 | `(if (,(primitive 'memv) ,exp '(,test)) | |
4281 | (begin ,b1 ,@body) | |
4282 | ,(loop (cons exp rest)))) | |
4283 | ((exp . rest) | |
4284 | (if (not (symbol? exp)) | |
4285 | (let ((g (gensym))) | |
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) | |
4290 | (define quote-tf | |
4291 | (lambda (exp) | |
4292 | (letrec ((qloop (match-lambda | |
4293 | ((? box? q) | |
4294 | `(,(primitive qbox) ,(qloop (unbox q)))) | |
4295 | ((? symbol? q) `',q) | |
4296 | ((? null? q) q) | |
4297 | ((? list? q) | |
4298 | (if (< (length q) conslimit) | |
4299 | `(,(primitive qcons) | |
4300 | ,(qloop (car q)) | |
4301 | ,(qloop (cdr q))) | |
4302 | `(,(primitive qlist) ,@(map qloop q)))) | |
4303 | ((x . y) | |
4304 | `(,(primitive qcons) ,(qloop x) ,(qloop y))) | |
4305 | ((? vector? q) | |
4306 | `(,(primitive qvector) | |
4307 | ,@(map qloop (vector->list q)))) | |
4308 | ((? boolean? q) q) | |
4309 | ((? number? q) q) | |
4310 | ((? char? q) q) | |
4311 | ((? string? q) q) | |
4312 | (q (syntax-err | |
4313 | exp | |
4314 | "invalid quote expression at ~a" | |
4315 | q))))) | |
4316 | (match exp | |
4317 | (('quote q) (qloop q)) | |
4318 | ((? vector? q) (qloop q)) | |
4319 | ((? box? q) (qloop q)))))) | |
4320 | (define quasiquote-tf | |
4321 | (lambda (exp) | |
4322 | (letrec ((make-cons | |
4323 | (lambda (x y) | |
4324 | (cond ((null? y) `(,(primitive 'list) ,x)) | |
4325 | ((and (pair? y) | |
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) | |
4330 | (match e | |
4331 | (('quasiquote e) | |
4332 | (make-cons 'quasiquote (qloop `(,e) (+ 1 n)))) | |
4333 | (('unquote e) | |
4334 | (if (zero? n) | |
4335 | e | |
4336 | (make-cons 'unquote (qloop `(,e) (- n 1))))) | |
4337 | (('unquote-splicing e) | |
4338 | (if (zero? n) | |
4339 | e | |
4340 | (make-cons | |
4341 | 'unquote-splicing | |
4342 | (qloop `(,e) (- n 1))))) | |
4343 | ((('unquote-splicing e) . y) | |
4344 | (=> fail) | |
4345 | (if (zero? n) | |
4346 | (if (null? y) | |
4347 | e | |
4348 | `(,(primitive 'append) ,e ,(qloop y n))) | |
4349 | (fail))) | |
4350 | ((? box? q) | |
4351 | `(,(primitive 'box) ,(qloop (unbox q) n))) | |
4352 | ((? symbol? q) | |
4353 | (if (memq q | |
4354 | '(quasiquote unquote unquote-splicing)) | |
4355 | (syntax-err | |
4356 | exp | |
4357 | "invalid use of ~a inside quasiquote" | |
4358 | q) | |
4359 | `',q)) | |
4360 | ((? null? q) q) | |
4361 | ((x . y) (make-cons (qloop x n) (qloop y n))) | |
4362 | ((? vector? q) | |
4363 | `(,(primitive 'vector) | |
4364 | ,@(map (lambda (z) (qloop z n)) | |
4365 | (vector->list q)))) | |
4366 | ((? boolean? q) q) | |
4367 | ((? number? q) q) | |
4368 | ((? char? q) q) | |
4369 | ((? string? q) q) | |
4370 | (q (syntax-err | |
4371 | exp | |
4372 | "invalid quasiquote expression at ~a" | |
4373 | q)))))) | |
4374 | (match exp (('quasiquote q) (qloop q 0)))))) | |
4375 | (define do-tf | |
4376 | (lambda (do-expr) | |
4377 | (recur loop | |
4378 | ((e (cdr do-expr))) | |
4379 | (match e | |
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) | |
4386 | (match s | |
4387 | (() v) | |
4388 | ((e) e) | |
4389 | (_ (syntax-err | |
4390 | do-expr | |
4391 | "invalid do expression")))) | |
4392 | var | |
4393 | step))) | |
4394 | (let ((doloop (gensym))) | |
4395 | (match e1 | |
4396 | (() | |
4397 | `(let ,doloop | |
4398 | ,(map list var init) | |
4399 | (if (not ,e0) | |
4400 | (begin ,@c (,doloop ,@step) (void)) | |
4401 | (void)))) | |
4402 | ((body0 ? list? body) | |
4403 | `(let ,doloop | |
4404 | ,(map list var init) | |
4405 | (if ,e0 | |
4406 | (begin ,body0 ,@body) | |
4407 | (begin ,@c (,doloop ,@step))))) | |
4408 | (_ (syntax-err | |
4409 | do-expr | |
4410 | "invalid do expression"))))) | |
4411 | (syntax-err do-expr "invalid do expression"))) | |
4412 | (_ (syntax-err do-expr "invalid do expression")))))) | |
4413 | (define empty-env '()) | |
4414 | (define lookup | |
4415 | (lambda (env x) | |
4416 | (match (assq x env) | |
4417 | (#f (disaster 'lookup "no binding for ~a" x)) | |
4418 | ((_ . b) b)))) | |
4419 | (define lookup? | |
4420 | (lambda (env x) | |
4421 | (match (assq x env) (#f #f) ((_ . b) b)))) | |
4422 | (define bound? | |
4423 | (lambda (env x) | |
4424 | (match (assq x env) (#f #f) (_ #t)))) | |
4425 | (define extend-env | |
4426 | (lambda (env x v) (cons (cons x v) env))) | |
4427 | (define extend-env* | |
4428 | (lambda (env xs vs) | |
4429 | (append (map2 cons xs vs) env))) | |
4430 | (define join-env | |
4431 | (lambda (env newenv) (append newenv env))) | |
4432 | (define populated #t) | |
4433 | (define pseudo #f) | |
4434 | (define global-error #f) | |
4435 | (define share #f) | |
4436 | (define matchst #f) | |
4437 | (define fullsharing #t) | |
4438 | (define dump-depths #f) | |
4439 | (define flags #t) | |
4440 | (define-structure | |
4441 | (c depth kind fsym pres args next)) | |
4442 | (define-structure | |
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))) | |
4449 | (define new-type | |
4450 | (lambda (s d) | |
4451 | (let ((t (box s))) | |
4452 | (vector-set! | |
4453 | types | |
4454 | d | |
4455 | (cons t (vector-ref types d))) | |
4456 | t))) | |
4457 | (define generate-counter | |
4458 | (lambda () | |
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))) | |
4463 | (define make-tvar | |
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! | |
4472 | (lambda () | |
4473 | (set! depth ord-depth) | |
4474 | (set! types (make-vector 16 '())))) | |
4475 | (define push-level | |
4476 | (lambda () | |
4477 | (set! depth (+ depth 1)) | |
4478 | (when (< (vector-length types) (+ 1 depth)) | |
4479 | (set! types | |
4480 | (let ((l (vector->list types))) | |
4481 | (list->vector | |
4482 | (append l (map (lambda (_) '()) l)))))))) | |
4483 | (define pop-level | |
4484 | (lambda () | |
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))) | |
4490 | (define tvar v-ord) | |
4491 | (define out1tvar | |
4492 | (lambda () (make-tvar (- depth 1) 'ord))) | |
4493 | (define monotvar | |
4494 | (lambda () (make-tvar ord-depth 'ord))) | |
4495 | (define pvar | |
4496 | (match-lambda | |
4497 | (($ box (and x ($ v d k _ vis _ _))) | |
4498 | (unless | |
4499 | (number? (v-name x)) | |
4500 | (set-v-name! x ((v-name x)))) | |
4501 | (string->symbol | |
4502 | (sprintf | |
4503 | "~a~a~a" | |
4504 | (match k | |
4505 | ('ord | |
4506 | (if (generic? d) | |
4507 | (if vis "X" "x") | |
4508 | (if vis "Z" "z"))) | |
4509 | ('abs (if vis "A" "a")) | |
4510 | ('pre (if vis "P" "p"))) | |
4511 | (v-name x) | |
4512 | (if dump-depths (sprintf ".~a" d) "")))))) | |
4513 | (define make-tvar-like | |
4514 | (match-lambda | |
4515 | (($ box ($ v d k _ _ _ _)) (make-tvar d k)))) | |
4516 | (define ind* | |
4517 | (lambda (t) | |
4518 | (match (unbox t) | |
4519 | ((? box? u) | |
4520 | (let ((v (ind* u))) (set-box! t v) v)) | |
4521 | (_ t)))) | |
4522 | (define type-check? | |
4523 | (match-lambda | |
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) | |
4528 | (else #f))))) | |
4529 | (define type-check1? | |
4530 | (match-lambda | |
4531 | ((abs def inexhaust _ _) | |
4532 | (cond ((check-abs1? abs) | |
4533 | (if (and def (definite? def)) 'def #t)) | |
4534 | (inexhaust 'inexhaust) | |
4535 | (else #f))))) | |
4536 | (define check-abs? | |
4537 | (lambda (vlist) | |
4538 | (letrec ((seen '()) | |
4539 | (labs? (lambda (t) | |
4540 | (match t | |
4541 | (($ box ($ v _ _ _ _ _ inst)) | |
4542 | (and inst | |
4543 | (not (memq t seen)) | |
4544 | (begin | |
4545 | (set! seen (cons t seen)) | |
4546 | (ormap (match-lambda ((t . _) (labs? t))) | |
4547 | inst)))) | |
4548 | (($ box ($ c _ _ _ p _ n)) | |
4549 | (or (labs? p) (labs? n))) | |
4550 | (($ box (? symbol?)) #t) | |
4551 | (($ box i) (labs? i)))))) | |
4552 | (ormap labs? vlist)))) | |
4553 | (define check-abs1? | |
4554 | (lambda (vlist) | |
4555 | (letrec ((labs1? | |
4556 | (lambda (t) | |
4557 | (match t | |
4558 | (($ box (? v?)) #f) | |
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 | |
4565 | (lambda (info) | |
4566 | (letrec ((seen '()) | |
4567 | (lsrcs (lambda (t source) | |
4568 | (match t | |
4569 | (($ box ($ v _ k _ _ _ inst)) | |
4570 | (union (if (and inst (not (memq t seen))) | |
4571 | (begin | |
4572 | (set! seen (cons t seen)) | |
4573 | (foldr union | |
4574 | empty-set | |
4575 | (map (match-lambda | |
4576 | ((t . s) (lsrcs t s))) | |
4577 | inst))) | |
4578 | empty-set))) | |
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)))))) | |
4584 | (match-let | |
4585 | (((abs _ _ _ _) info)) | |
4586 | (if (eq? #t abs) | |
4587 | empty-set | |
4588 | (foldr union | |
4589 | empty-set | |
4590 | (map (lambda (t) (lsrcs t #f)) abs))))))) | |
4591 | (define check-local-sources | |
4592 | (match-lambda ((_ _ _ _ component) component))) | |
4593 | (define mk-definite-prim | |
4594 | (match-lambda | |
4595 | (($ box ($ c _ _ x p a n)) | |
4596 | (if (eq? (k-name x) '?->) | |
4597 | (let ((seen '())) | |
4598 | (recur lprim | |
4599 | ((t (car a))) | |
4600 | (match t | |
4601 | (($ box ($ c _ _ x p a n)) | |
4602 | (if (memq t seen) | |
4603 | '() | |
4604 | (begin | |
4605 | (set! seen (cons t seen)) | |
4606 | (match (k-name x) | |
4607 | ('noarg (cons p (lprim n))) | |
4608 | ('arg | |
4609 | (let ((args (recur argloop | |
4610 | ((a (car a))) | |
4611 | (match a | |
4612 | (($ box | |
4613 | ($ c | |
4614 | _ | |
4615 | _ | |
4616 | _ | |
4617 | p | |
4618 | _ | |
4619 | n)) | |
4620 | (cons p | |
4621 | (argloop | |
4622 | n))) | |
4623 | (($ box | |
4624 | ($ v | |
4625 | _ | |
4626 | k | |
4627 | _ | |
4628 | _ | |
4629 | _ | |
4630 | _)) | |
4631 | (if (ord? k) | |
4632 | (list a) | |
4633 | '())) | |
4634 | (($ box | |
4635 | (? symbol?)) | |
4636 | '()) | |
4637 | (($ box i) | |
4638 | (argloop i)))))) | |
4639 | (cons (list p args (lprim (cadr a))) | |
4640 | (lprim n)))))))) | |
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 | |
4650 | (match-lambda | |
4651 | (($ box ($ c _ _ _ p _ _)) (list p)))) | |
4652 | (define mk-definite-lam | |
4653 | (match-lambda | |
4654 | (($ box ($ c _ _ x p a n)) | |
4655 | (if (eq? (k-name x) '?->) | |
4656 | (let ((seen '())) | |
4657 | (recur llam | |
4658 | ((t (car a))) | |
4659 | (match t | |
4660 | (($ box ($ c _ _ x p a n)) | |
4661 | (if (memq t seen) | |
4662 | '() | |
4663 | (begin | |
4664 | (set! seen (cons t seen)) | |
4665 | (match (k-name x) | |
4666 | ('noarg (cons p (llam n))) | |
4667 | ('arg | |
4668 | (let ((args (list top))) | |
4669 | (cons (list p args (llam (cadr a))) | |
4670 | (llam n)))))))) | |
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)))) | |
4679 | (define definite? | |
4680 | (lambda (def-info) | |
4681 | (letrec ((non-empty? | |
4682 | (lambda (t) | |
4683 | (let ((seen '())) | |
4684 | (recur ldef | |
4685 | ((t t)) | |
4686 | (match t | |
4687 | (($ box ($ c _ _ _ p _ n)) | |
4688 | (or (ldef p) (ldef n))) | |
4689 | (($ box ($ v d k _ _ _ inst)) | |
4690 | (if (or global-error (abs? k)) | |
4691 | (and inst | |
4692 | (generic? d) | |
4693 | (not (memq t seen)) | |
4694 | (begin | |
4695 | (set! seen (cons t seen)) | |
4696 | (ormap (match-lambda | |
4697 | ((t . _) (ldef t))) | |
4698 | inst))) | |
4699 | (generic? d))) | |
4700 | (($ box 'top) #t) | |
4701 | (($ box 'bot) #f) | |
4702 | (($ box i) (ldef i))))))) | |
4703 | (ok (lambda (l) | |
4704 | (ormap (match-lambda | |
4705 | ((? box? t) (non-empty? t)) | |
4706 | ((p arg rest) | |
4707 | (and (non-empty? p) | |
4708 | (ormap non-empty? arg) | |
4709 | (ok rest)))) | |
4710 | l)))) | |
4711 | (not (ok def-info))))) | |
4712 | (define close | |
4713 | (lambda (t-list) (close-type t-list #f))) | |
4714 | (define closeall | |
4715 | (lambda (t) (car (close-type (list t) #t)))) | |
4716 | (define for | |
4717 | (lambda (from to f) | |
4718 | (cond ((= from to) (f from)) | |
4719 | ((< from to) | |
4720 | (begin (f from) (for (+ from 1) to f))) | |
4721 | (else #f)))) | |
4722 | (define close-type | |
4723 | (lambda (t-list all?) | |
4724 | (let* ((sorted (make-vector (+ depth 1) '())) | |
4725 | (sort (lambda (t) | |
4726 | (match t | |
4727 | (($ box ($ c d _ _ _ _ _)) | |
4728 | (vector-set! | |
4729 | sorted | |
4730 | d | |
4731 | (cons t (vector-ref sorted d)))) | |
4732 | (($ box ($ v d _ _ _ _ _)) | |
4733 | (vector-set! | |
4734 | sorted | |
4735 | d | |
4736 | (cons t (vector-ref sorted d)))) | |
4737 | (_ #f)))) | |
4738 | (prop-d | |
4739 | (lambda (down) | |
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))) | |
4744 | (when (< down d) | |
4745 | (set-c-depth! x down) | |
4746 | (pr p) | |
4747 | (for-each pr a) | |
4748 | (pr n))) | |
4749 | (($ box (? symbol?)) #f) | |
4750 | (z (pr (ind* z)))))) | |
4751 | (match-lambda | |
4752 | (($ box (and x ($ c d _ _ p a n))) | |
4753 | (when (<= down d) (pr p) (for-each pr a) (pr n))) | |
4754 | (_ #f))))) | |
4755 | (prop-k | |
4756 | (lambda (t) | |
4757 | (let ((pk (lambda (kind) | |
4758 | (rec pr | |
4759 | (match-lambda | |
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) | |
4765 | (pr p) | |
4766 | (unless populated (for-each pr a)) | |
4767 | (pr n))) | |
4768 | (($ box (? symbol?)) #f) | |
4769 | (z (pr (ind* z)))))))) | |
4770 | (match t | |
4771 | (($ box (and x ($ c _ k _ p a n))) | |
4772 | (when (not (ord? k)) | |
4773 | (let ((prop (pk k))) | |
4774 | (prop p) | |
4775 | (unless populated (for-each prop a)) | |
4776 | (prop n)))) | |
4777 | (_ #f))))) | |
4778 | (might-be-generalized? | |
4779 | (match-lambda | |
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))) | |
4785 | (leaves '()) | |
4786 | (depth-of | |
4787 | (match-lambda | |
4788 | (($ box ($ v d _ _ _ _ _)) d) | |
4789 | (($ box ($ c d _ _ _ _ _)) d))) | |
4790 | (vector-grow | |
4791 | (lambda (v) | |
4792 | (let* ((n (vector-length v)) | |
4793 | (v2 (make-vector (* n 2) '()))) | |
4794 | (recur loop | |
4795 | ((i 0)) | |
4796 | (when (< i n) | |
4797 | (vector-set! v2 i (vector-ref v i)) | |
4798 | (loop (+ 1 i)))) | |
4799 | v2))) | |
4800 | (parents (make-vector 64 '())) | |
4801 | (parent-index 0) | |
4802 | (parents-of | |
4803 | (lambda (t) | |
4804 | (let ((d (depth-of t))) | |
4805 | (if (< depth d) | |
4806 | (vector-ref parents (- (- d depth) 1)) | |
4807 | '())))) | |
4808 | (xtnd-parents! | |
4809 | (lambda (t parent) | |
4810 | (match t | |
4811 | (($ box (and x ($ v d _ _ _ _ _))) | |
4812 | (when (= d depth) | |
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))) | |
4818 | (vector-set! | |
4819 | parents | |
4820 | (- (- d depth) 1) | |
4821 | (cons parent | |
4822 | (vector-ref parents (- (- d depth) 1))))) | |
4823 | (($ box (and x ($ c d _ _ _ _ _))) | |
4824 | (when (= d depth) | |
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))) | |
4830 | (vector-set! | |
4831 | parents | |
4832 | (- (- d depth) 1) | |
4833 | (cons parent | |
4834 | (vector-ref parents (- (- d depth) 1)))))))) | |
4835 | (needs-cleanup '()) | |
4836 | (revtype | |
4837 | (rec revtype | |
4838 | (lambda (parent t) | |
4839 | (let ((t (ind* t))) | |
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)) | |
4844 | (match t | |
4845 | (($ box (? v?)) | |
4846 | (set! leaves (cons t leaves))) | |
4847 | (($ box ($ c _ _ _ p a n)) | |
4848 | (let ((rev (lambda (q) (revtype t q)))) | |
4849 | (rev p) | |
4850 | (for-each rev a) | |
4851 | (rev n))))) | |
4852 | ((not (memq parent (parents-of t))) | |
4853 | (xtnd-parents! t parent)) | |
4854 | (else #f)))))) | |
4855 | (generic-index 0) | |
4856 | (gen (rec gen | |
4857 | (lambda (t) | |
4858 | (let ((t (ind* t))) | |
4859 | (when (might-be-generalized? t) | |
4860 | (set! generic-index (- generic-index 1)) | |
4861 | (let ((parents (parents-of t))) | |
4862 | (match t | |
4863 | (($ box (and x ($ v _ k _ _ _ _))) | |
4864 | (set-v-depth! x generic-index) | |
4865 | (when (and populated | |
4866 | (or global-error | |
4867 | (abs? k) | |
4868 | (pre? k)) | |
4869 | (not all?)) | |
4870 | (set-v-inst! x '()))) | |
4871 | (($ box (? c? x)) | |
4872 | (set-c-depth! x generic-index))) | |
4873 | (for-each gen parents))))))) | |
4874 | (cleanup | |
4875 | (match-lambda | |
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)))))) | |
4880 | (gen2 (rec gen | |
4881 | (lambda (t) | |
4882 | (let ((t (ind* t))) | |
4883 | (when (might-be-generalized? t) | |
4884 | (set! generic-index (- generic-index 1)) | |
4885 | (match t | |
4886 | (($ box (and x ($ v _ k _ _ _ _))) | |
4887 | (set-v-depth! x generic-index) | |
4888 | (when (and populated | |
4889 | (or global-error | |
4890 | (abs? k) | |
4891 | (pre? k)) | |
4892 | (not all?)) | |
4893 | (set-v-inst! x '()))) | |
4894 | (($ box (and x ($ c _ _ _ p a n))) | |
4895 | (set-c-depth! x generic-index) | |
4896 | (gen p) | |
4897 | (for-each gen a) | |
4898 | (gen n)))))))) | |
4899 | (upd (lambda (t) | |
4900 | (let ((d (depth-of t))) | |
4901 | (when (< 0 d) | |
4902 | (vector-set! | |
4903 | types | |
4904 | d | |
4905 | (cons t (vector-ref types d)))))))) | |
4906 | (for-each sort (vector-ref types depth)) | |
4907 | (for 0 | |
4908 | (- depth 1) | |
4909 | (lambda (i) | |
4910 | (for-each (prop-d i) (vector-ref sorted i)))) | |
4911 | (for-each prop-k (vector-ref types depth)) | |
4912 | (vector-set! types depth '()) | |
4913 | (if fullsharing | |
4914 | (begin | |
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)) | |
4919 | (for 0 | |
4920 | depth | |
4921 | (lambda (i) (for-each upd (vector-ref sorted i)))) | |
4922 | (if (null? t-list) | |
4923 | '() | |
4924 | (match-let* | |
4925 | ((n-gen (- generic-index)) | |
4926 | ((t-list n-gen) | |
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) | |
4933 | (define visible | |
4934 | (lambda (t-list n-gen) | |
4935 | (let* ((before (cpu-time)) | |
4936 | (valences (make-vector n-gen '())) | |
4937 | (namer (generate-counter)) | |
4938 | (lvis (rec lvis | |
4939 | (lambda (t pos rcd) | |
4940 | (match t | |
4941 | (($ box ($ c d _ x p a n)) | |
4942 | (when (and (generic? d) | |
4943 | (not (element-of? | |
4944 | pos | |
4945 | (vector-ref | |
4946 | valences | |
4947 | (- (- d) 1))))) | |
4948 | (let ((u (union (vector-ref | |
4949 | valences | |
4950 | (- (- d) 1)) | |
4951 | (set pos)))) | |
4952 | (vector-set! valences (- (- d) 1) u)) | |
4953 | (lvis p pos rcd) | |
4954 | (match (k-name x) | |
4955 | ('?-> | |
4956 | (lvis (car a) (not pos) #f) | |
4957 | (lvis (cadr a) pos #f)) | |
4958 | ('record (lvis (car a) pos #t)) | |
4959 | (_ (for-each | |
4960 | (lambda (x) (lvis x pos #f)) | |
4961 | a))) | |
4962 | (lvis n pos rcd))) | |
4963 | (($ box (and x ($ v d k _ _ _ _))) | |
4964 | (when (and (generic? d) | |
4965 | (not (element-of? | |
4966 | pos | |
4967 | (vector-ref | |
4968 | valences | |
4969 | (- (- d) 1))))) | |
4970 | (let ((u (union (vector-ref | |
4971 | valences | |
4972 | (- (- d) 1)) | |
4973 | (set pos)))) | |
4974 | (vector-set! valences (- (- d) 1) u) | |
4975 | (set-v-name! x namer) | |
4976 | (cond ((abs? k) #f) | |
4977 | ((= 2 (cardinality u)) | |
4978 | (set-v-split! x #t) | |
4979 | (set-v-vis! x #t)) | |
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) | |
4985 | (set! visible-time | |
4986 | (+ visible-time (- (cpu-time) before)))))) | |
4987 | (define visible? | |
4988 | (match-lambda | |
4989 | (($ box ($ v _ k _ vis _ _)) | |
4990 | (or (pre? k) (and vis (not (abs? k))))) | |
4991 | (($ box 'top) #t) | |
4992 | (($ box 'bot) #f) | |
4993 | (($ box i) (visible? i)))) | |
4994 | (define instantiate | |
4995 | (lambda (ts syntax) | |
4996 | (match ts | |
4997 | (($ ts t n-gen) | |
4998 | (let* ((absv '()) | |
4999 | (seen (make-vector n-gen #f)) | |
5000 | (t2 (recur linst | |
5001 | ((t t)) | |
5002 | (match t | |
5003 | (($ box (and y ($ v d k _ _ _ inst))) | |
5004 | (cond ((not (generic? d)) t) | |
5005 | ((vector-ref seen (- (- d) 1))) | |
5006 | (else | |
5007 | (let ((u (make-tvar depth k))) | |
5008 | (vector-set! seen (- (- d) 1) u) | |
5009 | (when inst | |
5010 | (set-v-inst! | |
5011 | y | |
5012 | (cons (cons u syntax) | |
5013 | inst))) | |
5014 | (when (or (abs? k) (pre? k)) | |
5015 | (set! absv (cons u absv))) | |
5016 | u)))) | |
5017 | (($ box ($ c d _ x p a n)) | |
5018 | (cond ((not (generic? d)) t) | |
5019 | ((vector-ref seen (- (- d) 1))) | |
5020 | (else | |
5021 | (let ((u (new-type | |
5022 | '**fix** | |
5023 | depth))) | |
5024 | (vector-set! seen (- (- d) 1) u) | |
5025 | (set-box! | |
5026 | u | |
5027 | (make-c | |
5028 | depth | |
5029 | 'ord | |
5030 | x | |
5031 | (if flags (linst p) top) | |
5032 | (map linst a) | |
5033 | (linst n))) | |
5034 | u)))) | |
5035 | (($ box (? symbol?)) t) | |
5036 | (($ box i) (linst i)))))) | |
5037 | (list t2 absv)))))) | |
5038 | (define pseudo-subtype | |
5039 | (lambda (t-list n-gen) | |
5040 | (let* ((valences (make-vector n-gen '())) | |
5041 | (valence-of | |
5042 | (lambda (d) (vector-ref valences (- (- d) 1)))) | |
5043 | (set-valence | |
5044 | (lambda (d v) | |
5045 | (vector-set! valences (- (- d) 1) v))) | |
5046 | (find (rec find | |
5047 | (lambda (t pos mutable) | |
5048 | (match t | |
5049 | (($ box ($ v d _ _ _ _ _)) | |
5050 | (when (generic? d) | |
5051 | (cond (mutable | |
5052 | (set-valence d (set #t #f))) | |
5053 | ((not (element-of? | |
5054 | pos | |
5055 | (valence-of d))) | |
5056 | (set-valence | |
5057 | d | |
5058 | (union (valence-of d) | |
5059 | (set pos)))) | |
5060 | (else #f)))) | |
5061 | (($ box ($ c d _ x p a n)) | |
5062 | (when (generic? d) | |
5063 | (cond ((= 2 (cardinality (valence-of d))) | |
5064 | #f) | |
5065 | (mutable | |
5066 | (set-valence d (set #t #f)) | |
5067 | (for-each2 | |
5068 | (lambda (t m) | |
5069 | (find t pos mutable)) | |
5070 | a | |
5071 | (k-args x)) | |
5072 | (find n pos mutable)) | |
5073 | ((not (element-of? | |
5074 | pos | |
5075 | (valence-of d))) | |
5076 | (set-valence | |
5077 | d | |
5078 | (union (valence-of d) | |
5079 | (set pos))) | |
5080 | (if (eq? '?-> (k-name x)) | |
5081 | (begin | |
5082 | (find (car a) | |
5083 | (not pos) | |
5084 | mutable) | |
5085 | (find (cadr a) pos mutable)) | |
5086 | (for-each2 | |
5087 | (lambda (t m) | |
5088 | (find t pos (or m mutable))) | |
5089 | a | |
5090 | (k-args x))) | |
5091 | (find n pos mutable)) | |
5092 | (else #f)))) | |
5093 | (($ box (? symbol?)) #f) | |
5094 | (($ box i) (find i pos mutable)))))) | |
5095 | (seen (make-vector n-gen #f)) | |
5096 | (new-generic-var | |
5097 | (lambda () | |
5098 | (set! n-gen (+ 1 n-gen)) | |
5099 | (box (make-raw-tvar (- n-gen) 'ord)))) | |
5100 | (copy (rec copy | |
5101 | (lambda (t) | |
5102 | (match t | |
5103 | (($ box ($ v d k _ _ _ _)) | |
5104 | (if (generic? d) | |
5105 | (or (vector-ref seen (- (- d) 1)) | |
5106 | (let ((u (if (and (abs? k) | |
5107 | (equal? | |
5108 | (valence-of d) | |
5109 | '(#t))) | |
5110 | (new-generic-var) | |
5111 | t))) | |
5112 | (vector-set! seen (- (- d) 1) u) | |
5113 | u)) | |
5114 | t)) | |
5115 | (($ box ($ c d k x p a n)) | |
5116 | (if (generic? d) | |
5117 | (or (vector-ref seen (- (- d) 1)) | |
5118 | (let* ((u (box '**fix**)) | |
5119 | (_ (vector-set! | |
5120 | seen | |
5121 | (- (- d) 1) | |
5122 | u)) | |
5123 | (new-p (if (and (eq? (ind* p) top) | |
5124 | (equal? | |
5125 | (valence-of d) | |
5126 | '(#f))) | |
5127 | (new-generic-var) | |
5128 | (copy p))) | |
5129 | (new-a (map copy a)) | |
5130 | (new-n (copy n))) | |
5131 | (set-box! | |
5132 | u | |
5133 | (make-c d 'ord x new-p new-a new-n)) | |
5134 | u)) | |
5135 | t)) | |
5136 | (($ box (? symbol?)) t) | |
5137 | (($ box i) (copy i)))))) | |
5138 | (t-list | |
5139 | (map (lambda (t) (find t #t #f) (copy t)) t-list))) | |
5140 | (list t-list n-gen)))) | |
5141 | (set! pseudo pseudo-subtype) | |
5142 | (define unify | |
5143 | (letrec ((uni (lambda (u v) | |
5144 | (unless | |
5145 | (eq? u v) | |
5146 | (match (cons u v) | |
5147 | ((($ box (and us ($ c ud uk ux up ua un))) | |
5148 | $ | |
5149 | box | |
5150 | (and vs ($ c vd vk vx vp va vn))) | |
5151 | (if (eq? ux vx) | |
5152 | (begin | |
5153 | (if (< ud vd) | |
5154 | (begin | |
5155 | (set-box! v u) | |
5156 | (when (kind< vk uk) (set-c-kind! us vk))) | |
5157 | (begin | |
5158 | (set-box! u v) | |
5159 | (when (kind< uk vk) (set-c-kind! vs uk)))) | |
5160 | (uni un vn) | |
5161 | (for-each2 uni ua va) | |
5162 | (uni up vp)) | |
5163 | (let* ((next (tvar)) | |
5164 | (k (if (kind< uk vk) uk vk))) | |
5165 | (if (< ud vd) | |
5166 | (begin | |
5167 | (when (< vd ud) (set-c-depth! us vd)) | |
5168 | (when (kind< vk uk) (set-c-kind! us vk)) | |
5169 | (set-box! v u)) | |
5170 | (begin | |
5171 | (when (< ud vd) (set-c-depth! vs ud)) | |
5172 | (when (kind< uk vk) (set-c-kind! vs uk)) | |
5173 | (set-box! u v))) | |
5174 | (uni (new-type | |
5175 | (make-c depth k ux up ua next) | |
5176 | depth) | |
5177 | vn) | |
5178 | (uni un | |
5179 | (new-type | |
5180 | (make-c depth k vx vp va next) | |
5181 | depth))))) | |
5182 | ((($ box (and x ($ v ud uk _ _ _ _))) | |
5183 | $ | |
5184 | box | |
5185 | ($ v vd vk _ _ _ _)) | |
5186 | (set-v-depth! x (min ud vd)) | |
5187 | (set-v-kind! x (if (kind< uk vk) uk vk)) | |
5188 | (set-box! v u)) | |
5189 | ((($ box ($ v ud uk _ _ _ _)) | |
5190 | $ | |
5191 | box | |
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)) | |
5195 | (set-box! u v)) | |
5196 | ((($ box (and x ($ c ud uk _ _ _ _))) | |
5197 | $ | |
5198 | box | |
5199 | ($ v vd vk _ _ _ _)) | |
5200 | (when (< vd ud) (set-c-depth! x vd)) | |
5201 | (when (kind< vk uk) (set-c-kind! x vk)) | |
5202 | (set-box! v u)) | |
5203 | ((($ box ($ v _ _ _ _ _ _)) $ box (? symbol?)) | |
5204 | (set-box! u v)) | |
5205 | ((($ box (? symbol?)) $ box ($ v _ _ _ _ _ _)) | |
5206 | (set-box! v u)) | |
5207 | ((($ box 'bot) $ box ($ c _ _ _ p _ n)) | |
5208 | (set-box! v u) | |
5209 | (uni u p) | |
5210 | (uni u n)) | |
5211 | ((($ box ($ c _ _ _ p _ n)) $ box 'bot) | |
5212 | (set-box! u v) | |
5213 | (uni v p) | |
5214 | (uni v n)) | |
5215 | (_ (uni (ind* u) (ind* v)))))))) | |
5216 | uni)) | |
5217 | (define kind< | |
5218 | (lambda (k1 k2) (and (ord? k2) (not (ord? k1))))) | |
5219 | (define r+- | |
5220 | (lambda (flag+ flag- tail+- absent- pos env type) | |
5221 | (letrec ((absent+ v-ord) | |
5222 | (tvars '()) | |
5223 | (fvars '()) | |
5224 | (absv '()) | |
5225 | (make-flag | |
5226 | (lambda (pos) | |
5227 | (cond ((not flags) top) | |
5228 | (pos (flag+)) | |
5229 | (else (flag-))))) | |
5230 | (typevar? | |
5231 | (lambda (v) | |
5232 | (and (symbol? v) | |
5233 | (not (bound? env v)) | |
5234 | (not (memq v | |
5235 | '(_ bool | |
5236 | mu | |
5237 | list | |
5238 | &list | |
5239 | &optional | |
5240 | &rest | |
5241 | arglist | |
5242 | + | |
5243 | not | |
5244 | rec | |
5245 | *tidy)))))) | |
5246 | (parse-type | |
5247 | (lambda (t pos) | |
5248 | (match t | |
5249 | (('mu a t) | |
5250 | (unless | |
5251 | (typevar? a) | |
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))) | |
5258 | (when (eq? t fix) | |
5259 | (raise 'type | |
5260 | "recursive type is not contractive")) | |
5261 | (set-box! fix t) | |
5262 | (ind* t))) | |
5263 | (('rec (? list? bind) t2) | |
5264 | (for-each | |
5265 | (match-lambda | |
5266 | ((a _) | |
5267 | (unless | |
5268 | (typevar? a) | |
5269 | (raise 'type "invalid type syntax at ~a" t)) | |
5270 | (when (assq a tvars) | |
5271 | (raise 'type | |
5272 | "~a is defined more than once" | |
5273 | a)) | |
5274 | (set! tvars | |
5275 | (cons (list a (new-type '**fix** depth) '()) | |
5276 | tvars))) | |
5277 | (_ (raise 'type "invalid type syntax at ~a" t))) | |
5278 | bind) | |
5279 | (for-each | |
5280 | (match-lambda | |
5281 | ((a t) | |
5282 | (match (assq a tvars) | |
5283 | ((_ fix _) | |
5284 | (let ((t (parse-type t '?))) | |
5285 | (when (eq? t fix) | |
5286 | (raise 'type | |
5287 | "type is not contractive")) | |
5288 | (set-box! fix t)))))) | |
5289 | bind) | |
5290 | (parse-type t2 pos)) | |
5291 | ('bool (parse-type '(+ false true) pos)) | |
5292 | ('s-exp | |
5293 | (let ((v (gensym))) | |
5294 | (parse-type | |
5295 | `(mu ,v | |
5296 | (+ num | |
5297 | nil | |
5298 | false | |
5299 | true | |
5300 | char | |
5301 | sym | |
5302 | str | |
5303 | (vec ,v) | |
5304 | (box ,v) | |
5305 | (cons ,v ,v))) | |
5306 | pos))) | |
5307 | (('list t) | |
5308 | (let ((u (gensym))) | |
5309 | (parse-type `(mu ,u (+ nil (cons ,t ,u))) pos))) | |
5310 | (('arglist t) | |
5311 | (let ((u (gensym))) | |
5312 | (parse-type `(mu ,u (+ noarg (arg ,t ,u))) pos))) | |
5313 | (('+ ? list? union) (parse-union union pos)) | |
5314 | (t (parse-union (list t) pos))))) | |
5315 | (parse-union | |
5316 | (lambda (t pos) | |
5317 | (letrec ((sort-cs | |
5318 | (lambda (cs) | |
5319 | (sort-list | |
5320 | cs | |
5321 | (lambda (x y) (k< (c-fsym x) (c-fsym y)))))) | |
5322 | (link (lambda (c t) | |
5323 | (set-c-next! c t) | |
5324 | (new-type c depth)))) | |
5325 | (recur loop | |
5326 | ((t t) (cs '())) | |
5327 | (match t | |
5328 | (() | |
5329 | (foldr link | |
5330 | (if pos | |
5331 | (absent+) | |
5332 | (let ((v (absent-))) | |
5333 | (set! absv (cons v absv)) | |
5334 | v)) | |
5335 | (sort-cs cs))) | |
5336 | (((? box? t)) (foldr link t (sort-cs cs))) | |
5337 | (('_) (foldr link (tail+-) (sort-cs cs))) | |
5338 | (((? symbol? a)) | |
5339 | (=> fail) | |
5340 | (unless (typevar? a) (fail)) | |
5341 | (let* ((cs (sort-cs cs)) | |
5342 | (ks (map c-fsym cs))) | |
5343 | (foldr link | |
5344 | (match (assq a tvars) | |
5345 | ((_ f aks) | |
5346 | (unless | |
5347 | (equal? ks aks) | |
5348 | (raise 'type | |
5349 | "variable ~a is not tidy" | |
5350 | a)) | |
5351 | f) | |
5352 | (#f | |
5353 | (let ((v (tail+-))) | |
5354 | (set! tvars | |
5355 | (cons (list a v ks) | |
5356 | tvars)) | |
5357 | v))) | |
5358 | cs))) | |
5359 | ((k . rest) | |
5360 | (loop rest (cons (parse-k k pos) cs)))))))) | |
5361 | (parse-k | |
5362 | (lambda (k pos) | |
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))) | |
5368 | (res (car rk))) | |
5369 | (letrec ((mkargs | |
5370 | (match-lambda | |
5371 | (() 'noarg) | |
5372 | ((('&rest x)) x) | |
5373 | ((('&list x)) | |
5374 | (let ((u (gensym))) | |
5375 | `(mu ,u (+ noarg (arg ,x ,u))))) | |
5376 | ((('&optional x)) | |
5377 | `(+ noarg (arg ,x noarg))) | |
5378 | ((x . y) `(arg ,x ,(mkargs y))) | |
5379 | (_ (raise 'type | |
5380 | "invalid type syntax"))))) | |
5381 | (make-c | |
5382 | depth | |
5383 | 'ord | |
5384 | (lookup env '?->) | |
5385 | (make-flag pos) | |
5386 | (let ((a (parse-type (mkargs arg) (flip pos))) | |
5387 | (r (parse-type res pos))) | |
5388 | (list a r)) | |
5389 | '**fix**)))) | |
5390 | (else | |
5391 | (match k | |
5392 | ((arg '?-> res) | |
5393 | (make-c | |
5394 | depth | |
5395 | 'ord | |
5396 | (lookup env '?->) | |
5397 | (make-flag pos) | |
5398 | (let ((a (parse-type arg (flip pos))) | |
5399 | (r (parse-type res pos))) | |
5400 | (list a r)) | |
5401 | '**fix**)) | |
5402 | (('record ? list? fields) | |
5403 | (make-c | |
5404 | depth | |
5405 | 'ord | |
5406 | (lookup env 'record) | |
5407 | (make-flag pos) | |
5408 | (list (recur loop | |
5409 | ((fields fields)) | |
5410 | (match fields | |
5411 | (() (if pos bot (v-ord))) | |
5412 | ((((? symbol? f) ftype) | |
5413 | . | |
5414 | rest) | |
5415 | (new-type | |
5416 | (make-c | |
5417 | depth | |
5418 | 'ord | |
5419 | (new-field! f) | |
5420 | (if pos | |
5421 | (v-ord) | |
5422 | (let ((v (v-pre))) | |
5423 | (set! absv | |
5424 | (cons v absv)) | |
5425 | v)) | |
5426 | (list (parse-type | |
5427 | ftype | |
5428 | pos)) | |
5429 | (loop rest)) | |
5430 | depth))))) | |
5431 | '**fix**)) | |
5432 | (('not (? k? k)) | |
5433 | (make-c | |
5434 | depth | |
5435 | 'ord | |
5436 | k | |
5437 | (if pos | |
5438 | (absent+) | |
5439 | (let ((v (absent-))) | |
5440 | (set! absv (cons v absv)) | |
5441 | v)) | |
5442 | (map (lambda (x) (tail+-)) (k-args k)) | |
5443 | '**fix**)) | |
5444 | (('not c) | |
5445 | (unless | |
5446 | (bound? env c) | |
5447 | (raise 'type "invalid type syntax at ~a" k)) | |
5448 | (let ((k (lookup env c))) | |
5449 | (make-c | |
5450 | depth | |
5451 | 'ord | |
5452 | k | |
5453 | (if pos | |
5454 | (absent+) | |
5455 | (let ((v (absent-))) | |
5456 | (set! absv (cons v absv)) | |
5457 | v)) | |
5458 | (map (lambda (x) (tail+-)) (k-args k)) | |
5459 | '**fix**))) | |
5460 | (('*tidy c (? symbol? f)) | |
5461 | (unless | |
5462 | (bound? env c) | |
5463 | (raise 'type "invalid type syntax at ~a" k)) | |
5464 | (let ((k (lookup env c))) | |
5465 | (make-c | |
5466 | depth | |
5467 | 'ord | |
5468 | k | |
5469 | (match (assq f fvars) | |
5470 | ((_ . f) f) | |
5471 | (#f | |
5472 | (let ((v (tail+-))) | |
5473 | (set! fvars | |
5474 | (cons (cons f v) fvars)) | |
5475 | v))) | |
5476 | (map (lambda (x) (parse-type '(+) pos)) | |
5477 | (k-args k)) | |
5478 | '**fix**))) | |
5479 | (((? k? k) ? list? arg) | |
5480 | (unless | |
5481 | (= (length arg) (length (k-args k))) | |
5482 | (raise 'type | |
5483 | "~a requires ~a arguments" | |
5484 | (k-name k) | |
5485 | (length (k-args k)))) | |
5486 | (make-c | |
5487 | depth | |
5488 | 'ord | |
5489 | k | |
5490 | (make-flag pos) | |
5491 | (smap (lambda (x) (parse-type x pos)) arg) | |
5492 | '**fix**)) | |
5493 | ((c ? list? arg) | |
5494 | (unless | |
5495 | (bound? env c) | |
5496 | (raise 'type "invalid type syntax at ~a" k)) | |
5497 | (let ((k (lookup env c))) | |
5498 | (unless | |
5499 | (= (length arg) (length (k-args k))) | |
5500 | (raise 'type | |
5501 | "~a requires ~a arguments" | |
5502 | c | |
5503 | (length (k-args k)))) | |
5504 | (make-c | |
5505 | depth | |
5506 | 'ord | |
5507 | k | |
5508 | (make-flag pos) | |
5509 | (smap (lambda (x) (parse-type x pos)) arg) | |
5510 | '**fix**))) | |
5511 | (c (unless | |
5512 | (bound? env c) | |
5513 | (raise 'type | |
5514 | "invalid type syntax at ~a" | |
5515 | k)) | |
5516 | (let ((k (lookup env c))) | |
5517 | (unless | |
5518 | (= 0 (length (k-args k))) | |
5519 | (raise 'type | |
5520 | "~a requires ~a arguments" | |
5521 | c | |
5522 | (length (k-args k)))) | |
5523 | (make-c | |
5524 | depth | |
5525 | 'ord | |
5526 | k | |
5527 | (make-flag pos) | |
5528 | '() | |
5529 | '**fix**)))))))) | |
5530 | (flip (match-lambda ('? '?) (#t #f) (#f #t)))) | |
5531 | (let ((t (parse-type type pos))) (list t absv))))) | |
5532 | (define v-top (lambda () top)) | |
5533 | (define r+ | |
5534 | (lambda (env t) | |
5535 | (car (r+- v-top v-ord v-ord v-abs #t env t)))) | |
5536 | (define r- | |
5537 | (lambda (env t) | |
5538 | (car (r+- v-top v-ord v-ord v-abs #f env t)))) | |
5539 | (define r++ | |
5540 | (lambda (env t) | |
5541 | (car (r+- v-top v-ord v-ord v-ord #t env t)))) | |
5542 | (define r+collect | |
5543 | (lambda (env t) | |
5544 | (r+- v-top v-ord v-ord v-abs #t env t))) | |
5545 | (define r-collect | |
5546 | (lambda (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))) | |
5549 | (define r-match | |
5550 | (lambda (t) | |
5551 | (close '()) | |
5552 | '(pretty-print `(fixing ,(ptype t))) | |
5553 | (fix-pat-abs! t) | |
5554 | (list t (collect-abs t)))) | |
5555 | (define collect-abs | |
5556 | (lambda (t) | |
5557 | (let ((seen '())) | |
5558 | (recur loop | |
5559 | ((t t)) | |
5560 | (match t | |
5561 | (($ box ($ v _ k _ _ _ _)) | |
5562 | (if (abs? k) (set t) empty-set)) | |
5563 | (($ box ($ c _ _ _ p a n)) | |
5564 | (if (memq t seen) | |
5565 | empty-set | |
5566 | (begin | |
5567 | (set! seen (cons t seen)) | |
5568 | (foldr union | |
5569 | (union (loop p) (loop n)) | |
5570 | (map loop a))))) | |
5571 | (($ box (? symbol?)) empty-set) | |
5572 | (($ box i) (loop i))))))) | |
5573 | (define fix-pat-abs! | |
5574 | (lambda (t) | |
5575 | (let ((seen '())) | |
5576 | (recur loop | |
5577 | ((t t)) | |
5578 | (match t | |
5579 | (($ box (and x ($ v d _ _ _ _ _))) | |
5580 | (when (= d depth) (set-v-kind! x 'abs))) | |
5581 | (($ box (and c ($ c _ _ _ p a n))) | |
5582 | (unless | |
5583 | (memq t seen) | |
5584 | (set! seen (cons t seen)) | |
5585 | (loop p) | |
5586 | (when (and matchst flags (eq? (ind* p) top)) | |
5587 | (set-c-pres! c (v-ord))) | |
5588 | (for-each loop a) | |
5589 | (loop n))) | |
5590 | (($ box (? symbol?)) t) | |
5591 | (($ box i) (loop i))))))) | |
5592 | (define pat-var-bind | |
5593 | (lambda (t) | |
5594 | (let ((seen '())) | |
5595 | (recur loop | |
5596 | ((t t)) | |
5597 | (match t | |
5598 | (($ box ($ v d _ _ _ _ _)) | |
5599 | (if (< d depth) | |
5600 | t | |
5601 | (match (assq t seen) | |
5602 | ((_ . new) new) | |
5603 | (#f | |
5604 | (let* ((new (v-ord))) | |
5605 | (set! seen (cons (cons t new) seen)) | |
5606 | new))))) | |
5607 | (($ box ($ c d k x p a n)) | |
5608 | (match (assq t seen) | |
5609 | ((_ . new) new) | |
5610 | (#f | |
5611 | (let* ((fix (new-type '**fix** depth)) | |
5612 | (fixbox (box fix)) | |
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))) | |
5617 | (k-args x) | |
5618 | a)) | |
5619 | (new-n (loop n))) | |
5620 | (if (and (eq? new-p p) | |
5621 | (eq? new-n n) | |
5622 | (andmap eq? new-a a)) | |
5623 | (begin (set-box! fixbox t) t) | |
5624 | (begin | |
5625 | (set-box! | |
5626 | fix | |
5627 | (make-c d k x new-p new-a new-n)) | |
5628 | fix)))))) | |
5629 | (($ box (? symbol?)) t) | |
5630 | (($ box i) (loop i))))))) | |
5631 | (define fields '()) | |
5632 | (define new-field! | |
5633 | (lambda (x) | |
5634 | (match (assq x fields) | |
5635 | (#f | |
5636 | (let ((k (make-k x (+ 1 (length fields)) '(#f)))) | |
5637 | (set! fields (cons (cons x k) fields)) | |
5638 | k)) | |
5639 | ((_ . k) k)))) | |
5640 | (define k< | |
5641 | (lambda (x y) (< (k-order x) (k-order y)))) | |
5642 | (define k-counter 0) | |
5643 | (define bind-tycon | |
5644 | (lambda (x args covers fail-thunk) | |
5645 | (when (memq x | |
5646 | '(_ bool | |
5647 | mu | |
5648 | list | |
5649 | &list | |
5650 | &optional | |
5651 | &rest | |
5652 | arglist | |
5653 | + | |
5654 | not | |
5655 | rec | |
5656 | *tidy)) | |
5657 | (fail-thunk "invalid type constructor ~a" x)) | |
5658 | (set! k-counter (+ 1 k-counter)) | |
5659 | (make-k | |
5660 | (if covers | |
5661 | (symbol-append x "." (- k-counter 100)) | |
5662 | x) | |
5663 | k-counter | |
5664 | args))) | |
5665 | (define initial-type-env '()) | |
5666 | (define init-types! | |
5667 | (lambda () | |
5668 | (set! k-counter 0) | |
5669 | (set! var-counter (generate-counter)) | |
5670 | (set! initial-type-env | |
5671 | (foldl (lambda (l env) | |
5672 | (extend-env | |
5673 | env | |
5674 | (car l) | |
5675 | (bind-tycon | |
5676 | (car l) | |
5677 | (cdr l) | |
5678 | #f | |
5679 | (lambda x (apply disaster 'init x))))) | |
5680 | empty-env | |
5681 | initial-type-info)) | |
5682 | (set! k-counter 100) | |
5683 | (reset-types!))) | |
5684 | (define reinit-types! | |
5685 | (lambda () | |
5686 | (set! var-counter (generate-counter)) | |
5687 | (set! k-counter 100) | |
5688 | (set! fields '()) | |
5689 | (set-cons-mutability! #t) | |
5690 | (reset-types!))) | |
5691 | (define deftype | |
5692 | (lambda (tag mutability) | |
5693 | (set! initial-type-env | |
5694 | (extend-env | |
5695 | initial-type-env | |
5696 | tag | |
5697 | (make-k | |
5698 | tag | |
5699 | (+ 1 (length initial-type-env)) | |
5700 | mutability))))) | |
5701 | (define initial-type-info | |
5702 | '((?-> #f #f) | |
5703 | (arg #f #f) | |
5704 | (noarg) | |
5705 | (num) | |
5706 | (nil) | |
5707 | (false) | |
5708 | (true) | |
5709 | (char) | |
5710 | (sym) | |
5711 | (str) | |
5712 | (void) | |
5713 | (iport) | |
5714 | (oport) | |
5715 | (eof) | |
5716 | (vec #t) | |
5717 | (box #t) | |
5718 | (cons #t #t) | |
5719 | (cvec #f) | |
5720 | (promise #t) | |
5721 | (record #f) | |
5722 | (module #f))) | |
5723 | (define cons-is-mutable #f) | |
5724 | (define set-cons-mutability! | |
5725 | (lambda (m) | |
5726 | (set! cons-is-mutable m) | |
5727 | (set-k-args! | |
5728 | (lookup initial-type-env 'cons) | |
5729 | (list m m)))) | |
5730 | (define tidy? | |
5731 | (lambda (t) | |
5732 | (let ((seen '())) | |
5733 | (recur loop | |
5734 | ((t t) (label '())) | |
5735 | (match t | |
5736 | (($ box (? v?)) | |
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)) | |
5743 | (#f | |
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))))))) | |
5749 | (define tidy | |
5750 | (match-lambda | |
5751 | (($ ts t _) | |
5752 | (tidy-print t print-union assemble-union #f)) | |
5753 | (t (tidy-print t print-union assemble-union #f)))) | |
5754 | (define ptype | |
5755 | (match-lambda | |
5756 | (($ ts t _) | |
5757 | (tidy-print | |
5758 | t | |
5759 | print-raw-union | |
5760 | assemble-raw-union | |
5761 | #t)) | |
5762 | (t (tidy-print | |
5763 | t | |
5764 | print-raw-union | |
5765 | assemble-raw-union | |
5766 | #t)))) | |
5767 | (define tidy-print | |
5768 | (lambda (t print assemble top) | |
5769 | (let* ((share (shared-unions t top)) | |
5770 | (bindings | |
5771 | (map-with-n | |
5772 | (lambda (t n) | |
5773 | (list t | |
5774 | (box #f) | |
5775 | (box #f) | |
5776 | (symbol-append "Y" (+ 1 n)))) | |
5777 | share)) | |
5778 | (body (print t (print-binding bindings))) | |
5779 | (let-bindings | |
5780 | (filter-map | |
5781 | (match-lambda | |
5782 | ((_ _ ($ box #f) _) #f) | |
5783 | ((_ ($ box t) ($ box x) _) (list x t))) | |
5784 | bindings))) | |
5785 | (assemble let-bindings body)))) | |
5786 | (define print-binding | |
5787 | (lambda (bindings) | |
5788 | (lambda (ty share-wrapper var-wrapper render) | |
5789 | (match (assq ty bindings) | |
5790 | (#f (render)) | |
5791 | ((_ box-tprint box-name nprint) | |
5792 | (var-wrapper | |
5793 | (or (unbox box-name) | |
5794 | (begin | |
5795 | (set-box! box-name nprint) | |
5796 | (set-box! box-tprint (share-wrapper (render))) | |
5797 | nprint)))))))) | |
5798 | (define shared-unions | |
5799 | (lambda (t all) | |
5800 | (let ((seen '())) | |
5801 | (recur loop | |
5802 | ((t t) (top #t)) | |
5803 | (match t | |
5804 | (($ box (? v?)) #f) | |
5805 | (($ box ($ c _ _ _ _ a n)) | |
5806 | (match (and top (assq t seen)) | |
5807 | (#f | |
5808 | (set! seen (cons (cons t (box 1)) seen)) | |
5809 | (for-each (lambda (x) (loop x #t)) a) | |
5810 | (loop n all)) | |
5811 | ((_ . b) (set-box! b (+ 1 (unbox b)))))) | |
5812 | (($ box (? symbol?)) #f) | |
5813 | (($ box i) (loop i top)))) | |
5814 | (reverse | |
5815 | (filter-map | |
5816 | (match-lambda ((_ $ box 1) #f) ((t . _) t)) | |
5817 | seen))))) | |
5818 | (define print-raw-union | |
5819 | (lambda (t print-share) | |
5820 | (recur loop | |
5821 | ((t t)) | |
5822 | (match t | |
5823 | (($ box ($ v _ _ _ _ split _)) | |
5824 | (if (and share split) | |
5825 | (string->symbol (sprintf "~a#" (pvar t))) | |
5826 | (pvar t))) | |
5827 | (($ box ($ c d k x p a n)) | |
5828 | (print-share | |
5829 | t | |
5830 | (lambda (x) x) | |
5831 | (lambda (x) x) | |
5832 | (lambda () | |
5833 | (let* ((name (if (abs? k) | |
5834 | (symbol-append '~ (k-name x)) | |
5835 | (k-name x))) | |
5836 | (name (if dump-depths | |
5837 | (symbol-append d '! name) | |
5838 | name)) | |
5839 | (pr-x `(,name ,@(maplr loop (cons p a))))) | |
5840 | (cons pr-x (loop n)))))) | |
5841 | (($ box 'top) '+) | |
5842 | (($ box 'bot) '-) | |
5843 | (($ box i) (loop i)))))) | |
5844 | (define assemble-raw-union | |
5845 | (lambda (bindings body) | |
5846 | (if (null? bindings) body `(rec ,bindings ,body)))) | |
5847 | (define print-union | |
5848 | (lambda (t print-share) | |
5849 | (add-+ (recur loop | |
5850 | ((t t) (tailvis (visible? (tailvar t)))) | |
5851 | (match t | |
5852 | (($ box (? v?)) | |
5853 | (if (visible? t) (list (pvar t)) '())) | |
5854 | (($ box ($ c _ _ x p a n)) | |
5855 | (print-share | |
5856 | t | |
5857 | add-+ | |
5858 | list | |
5859 | (lambda () | |
5860 | (cond ((visible? p) | |
5861 | (let* ((split-flag | |
5862 | (and share | |
5863 | (match (ind* p) | |
5864 | (($ box | |
5865 | ($ v | |
5866 | _ | |
5867 | _ | |
5868 | _ | |
5869 | _ | |
5870 | split | |
5871 | _)) | |
5872 | split) | |
5873 | (_ #f)))) | |
5874 | (kname (if split-flag | |
5875 | (string->symbol | |
5876 | (sprintf | |
5877 | "~a#~a" | |
5878 | (k-name x) | |
5879 | (pvar p))) | |
5880 | (k-name x)))) | |
5881 | (cons (cond ((null? a) kname) | |
5882 | ((eq? '?-> (k-name x)) | |
5883 | (let ((arg (add-+ (loop (car a) | |
5884 | (visible? | |
5885 | (tailvar | |
5886 | (car a)))))) | |
5887 | (res (add-+ (loop (cadr a) | |
5888 | (visible? | |
5889 | (tailvar | |
5890 | (cadr a))))))) | |
5891 | (decode-arrow | |
5892 | kname | |
5893 | (lambda () | |
5894 | (if split-flag | |
5895 | (string->symbol | |
5896 | (sprintf | |
5897 | "->#~a" | |
5898 | (pvar p))) | |
5899 | '->)) | |
5900 | arg | |
5901 | res))) | |
5902 | ((eq? 'record (k-name x)) | |
5903 | `(,kname | |
5904 | ,@(loop (car a) #f))) | |
5905 | (else | |
5906 | `(,kname | |
5907 | ,@(maplr (lambda (x) | |
5908 | (add-+ (loop x | |
5909 | (visible? | |
5910 | (tailvar | |
5911 | x))))) | |
5912 | a)))) | |
5913 | (loop n tailvis)))) | |
5914 | ((not tailvis) (loop n tailvis)) | |
5915 | (else | |
5916 | (cons `(not ,(k-name x)) | |
5917 | (loop n tailvis))))))) | |
5918 | (($ box 'bot) '()) | |
5919 | (($ box i) (loop i tailvis))))))) | |
5920 | (define assemble-union | |
5921 | (lambda (bindings body) | |
5922 | (subst-small-type | |
5923 | (map clean-binding bindings) | |
5924 | body))) | |
5925 | (define add-+ | |
5926 | (match-lambda | |
5927 | (() 'empty) | |
5928 | ((t) t) | |
5929 | (x (cons '+ x)))) | |
5930 | (define tailvar | |
5931 | (lambda (t) | |
5932 | (match t | |
5933 | (($ box (? v?)) t) | |
5934 | (($ box ($ c _ _ _ _ _ n)) (tailvar n)) | |
5935 | (($ box 'bot) t) | |
5936 | (($ box i) (tailvar i))))) | |
5937 | (define decode-arrow | |
5938 | (lambda (kname thunk-> arg res) | |
5939 | (let ((args (recur loop | |
5940 | ((l arg)) | |
5941 | (match l | |
5942 | ('noarg '()) | |
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))) | |
5948 | ((? symbol? z) | |
5949 | (if (rectypevar? z) `(,z) `((&rest ,z)))) | |
5950 | (('+ 'noarg z) (loop z)) | |
5951 | (('+ ('arg a b) z) | |
5952 | (loop `(+ (arg ,a ,b) noarg ,z))))))) | |
5953 | `(,@args ,(thunk->) ,res)))) | |
5954 | (define rectypevar? | |
5955 | (lambda (s) | |
5956 | (memq (string-ref (symbol->string s) 0) '(#\Y)))) | |
5957 | (define typevar? | |
5958 | (lambda (s) | |
5959 | (memq (string-ref (symbol->string s) 0) | |
5960 | '(#\X #\Z)))) | |
5961 | (define clean-binding | |
5962 | (lambda (binding) | |
5963 | (match binding | |
5964 | ((u ('+ 'nil ('cons a v))) | |
5965 | (if (and (equal? u v) (not (memq* u a))) | |
5966 | (list u `(list ,a)) | |
5967 | binding)) | |
5968 | ((u ('+ ('cons a v) 'nil)) | |
5969 | (if (and (equal? u v) (not (memq* u a))) | |
5970 | (list u `(list ,a)) | |
5971 | binding)) | |
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)) | |
5975 | binding)) | |
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)) | |
5979 | binding)) | |
5980 | ((u ('+ 'noarg ('arg a v))) | |
5981 | (if (and (equal? u v) (not (memq* u a))) | |
5982 | (list u `(&list ,a)) | |
5983 | binding)) | |
5984 | ((u ('+ ('arg a v) 'noarg)) | |
5985 | (if (and (equal? u v) (not (memq* u a))) | |
5986 | (list u `(&list ,a)) | |
5987 | binding)) | |
5988 | (x x)))) | |
5989 | (define memq* | |
5990 | (lambda (v t) | |
5991 | (recur loop | |
5992 | ((t t)) | |
5993 | (match t | |
5994 | ((x . y) (or (loop x) (loop y))) | |
5995 | (_ (eq? v t)))))) | |
5996 | (define subst-type | |
5997 | (lambda (new old t) | |
5998 | (match new | |
5999 | (('list elem) (subst-list elem old t)) | |
6000 | (_ (subst* new old t))))) | |
6001 | (define subst-list | |
6002 | (lambda (elem old t) | |
6003 | (match 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)) | |
6007 | `(list ,elem) | |
6008 | `(+ nil (cons ,(subst-list elem old a) ,b)))) | |
6009 | (('+ ('cons a (? symbol? b)) 'nil) | |
6010 | (if (and (eq? b old) (equal? elem a)) | |
6011 | `(list ,elem) | |
6012 | `(+ nil (cons ,(subst-list elem old a) ,b)))) | |
6013 | ((a . b) | |
6014 | (cons (subst-list elem old a) | |
6015 | (subst-list elem old b))) | |
6016 | (z z)))) | |
6017 | (define subst* | |
6018 | (lambda (new old t) | |
6019 | (cond ((eq? old t) new) | |
6020 | ((pair? t) | |
6021 | (cons (subst* new old (car t)) | |
6022 | (subst* new old (cdr t)))) | |
6023 | (else t)))) | |
6024 | (define subst-small-type | |
6025 | (lambda (bindings body) | |
6026 | (recur loop | |
6027 | ((bindings bindings) (newb '()) (body body)) | |
6028 | (match bindings | |
6029 | (() | |
6030 | (let ((newb (filter | |
6031 | (match-lambda | |
6032 | ((name type) (not (equal? name type)))) | |
6033 | newb))) | |
6034 | (if (null? newb) | |
6035 | body | |
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))))))) | |
6043 | (define small-type? | |
6044 | (lambda (t) | |
6045 | (>= 8 | |
6046 | (recur loop | |
6047 | ((t t)) | |
6048 | (match t | |
6049 | ('+ 0) | |
6050 | ((? symbol? s) 1) | |
6051 | ((? number? n) 0) | |
6052 | ((x . y) (+ (loop x) (loop y))) | |
6053 | (() 0)))))) | |
6054 | (define qop | |
6055 | (lambda (s) | |
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 | |
6062 | `((not (a -> bool)) | |
6063 | (eqv? (a a -> bool)) | |
6064 | (eq? (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) | |
6070 | (s ((x . _) . _))) | |
6071 | (cadr ((cons c (cons a b)) -> a) (s (_ x . _))) | |
6072 | (cdar ((cons (cons b a) c) -> a) | |
6073 | (s ((_ . x) . _))) | |
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) | |
6082 | (s (_ _ x . _))) | |
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) | |
6090 | (s (_ _ _ . x))) | |
6091 | (caaaar | |
6092 | ((cons (cons (cons (cons a b) c) d) e) -> a) | |
6093 | (s ((((x . _) . _) . _) . _))) | |
6094 | (caaadr | |
6095 | ((cons e (cons (cons (cons a b) c) d)) -> a) | |
6096 | (s (_ ((x . _) . _) . _))) | |
6097 | (caadar | |
6098 | ((cons (cons d (cons (cons a b) c)) e) -> a) | |
6099 | (s ((_ (x . _) . _) . _))) | |
6100 | (caaddr | |
6101 | ((cons e (cons d (cons (cons a b) c))) -> a) | |
6102 | (s (_ _ (x . _) . _))) | |
6103 | (cadaar | |
6104 | ((cons (cons (cons c (cons a b)) d) e) -> a) | |
6105 | (s (((_ x . _) . _) . _))) | |
6106 | (cadadr | |
6107 | ((cons e (cons (cons c (cons a b)) d)) -> a) | |
6108 | (s (_ (_ x . _) . _))) | |
6109 | (caddar | |
6110 | ((cons (cons d (cons c (cons a b))) e) -> a) | |
6111 | (s ((_ _ x . _) . _))) | |
6112 | (cadddr | |
6113 | ((cons e (cons d (cons c (cons a b)))) -> a) | |
6114 | (s (_ _ _ x . _))) | |
6115 | (cdaaar | |
6116 | ((cons (cons (cons (cons b a) c) d) e) -> a) | |
6117 | (s ((((_ . x) . _) . _) . _))) | |
6118 | (cdaadr | |
6119 | ((cons e (cons (cons (cons b a) c) d)) -> a) | |
6120 | (s (_ ((_ . x) . _) . _))) | |
6121 | (cdadar | |
6122 | ((cons (cons d (cons (cons b a) c)) e) -> a) | |
6123 | (s ((_ (_ . x) . _) . _))) | |
6124 | (cdaddr | |
6125 | ((cons e (cons d (cons (cons b a) c))) -> a) | |
6126 | (s (_ _ (_ . x) . _))) | |
6127 | (cddaar | |
6128 | ((cons (cons (cons c (cons b a)) d) e) -> a) | |
6129 | (s (((_ _ . x) . _) . _))) | |
6130 | (cddadr | |
6131 | ((cons e (cons (cons c (cons b a)) d)) -> a) | |
6132 | (s (_ (_ _ . x) . _))) | |
6133 | (cdddar | |
6134 | ((cons (cons d (cons c (cons b a))) e) -> a) | |
6135 | (s ((_ _ _ . x) . _))) | |
6136 | (cddddr | |
6137 | ((cons e (cons d (cons c (cons b a)))) -> a) | |
6138 | (s (_ _ _ _ . x))) | |
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))))) | |
6149 | (member | |
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)) | |
6157 | (real? (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)) | |
6178 | (abs (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)) | |
6191 | (exp (num -> num)) | |
6192 | (log (num -> num)) | |
6193 | (sin (num -> num)) | |
6194 | (cos (num -> num)) | |
6195 | (tan (num -> num)) | |
6196 | (asin (num -> num)) | |
6197 | (acos (num -> num)) | |
6198 | (atan (num (&optional num) -> num)) | |
6199 | (sqrt (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) | |
6265 | (i)) | |
6266 | (call-with-input-file | |
6267 | (str (iport -> a) -> a) | |
6268 | (i)) | |
6269 | (call-with-output-file | |
6270 | (str (oport -> a) -> a) | |
6271 | (i)) | |
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) | |
6283 | -> | |
6284 | (+ eof | |
6285 | num | |
6286 | nil | |
6287 | false | |
6288 | true | |
6289 | char | |
6290 | sym | |
6291 | str | |
6292 | (box (mu sexp | |
6293 | (+ num | |
6294 | nil | |
6295 | false | |
6296 | true | |
6297 | char | |
6298 | sym | |
6299 | str | |
6300 | (vec sexp) | |
6301 | (cons sexp sexp) | |
6302 | (box sexp)))) | |
6303 | (cons sexp sexp) | |
6304 | (vec sexp))) | |
6305 | (i)) | |
6306 | (read-char | |
6307 | ((&optional iport) -> (+ char eof)) | |
6308 | (i)) | |
6309 | (peek-char | |
6310 | ((&optional iport) -> (+ char eof)) | |
6311 | (i)) | |
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)) | |
6324 | (void (-> 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))) | |
6348 | (procedure? | |
6349 | ((+ ((&rest a) -> b) x) -> bool) | |
6350 | (p (?-> a b))) | |
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))) | |
6356 | (module? | |
6357 | ((+ (module a) x) -> bool) | |
6358 | (p (module a))) | |
6359 | (boolean? ((+ true false x) -> bool) (p #t)) | |
6360 | (list? ((mu u (+ nil (cons y u) x)) -> bool) | |
6361 | (p #t)))) | |
6362 | (define initial-env '()) | |
6363 | (define init-env! | |
6364 | (lambda () | |
6365 | (set! initial-env | |
6366 | (foldr init-prim empty-env initial-info)))) | |
6367 | (define init-prim | |
6368 | (lambda (l env) | |
6369 | (letrec ((build-selector | |
6370 | (match-lambda | |
6371 | ('x (lambda (x) x)) | |
6372 | ('_ (lambda (x) (make-pany))) | |
6373 | ('boxx | |
6374 | (let ((c (lookup env 'box?))) | |
6375 | (lambda (x) (make-pobj c (list x))))) | |
6376 | ((x . y) | |
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))))))))) | |
6381 | (match l | |
6382 | ((name type . attr) | |
6383 | (let* ((pure (cond ((assq 'i attr) #f) | |
6384 | ((assq 'ic attr) 'cons) | |
6385 | (else #t))) | |
6386 | (def (assq 'd attr)) | |
6387 | (check (assq 'c attr)) | |
6388 | (nocheck (assq 'n attr)) | |
6389 | (pred (match (assq 'p attr) | |
6390 | (#f #f) | |
6391 | ((_ #t) #t) | |
6392 | ((_ (tag . args)) | |
6393 | (cons (lookup initial-type-env tag) args)))) | |
6394 | (sel (match (assq 's attr) | |
6395 | (#f #f) | |
6396 | ((_ s) (build-selector s)))) | |
6397 | (env1 (extend-env | |
6398 | env | |
6399 | name | |
6400 | (make-name | |
6401 | name | |
6402 | (closeall (r+ initial-type-env type)) | |
6403 | #f | |
6404 | 0 | |
6405 | #f | |
6406 | #f | |
6407 | (cond (nocheck 'nocheck) | |
6408 | (check 'check) | |
6409 | (def 'imprecise) | |
6410 | (else #t)) | |
6411 | #f | |
6412 | pure | |
6413 | pred | |
6414 | #f | |
6415 | sel))) | |
6416 | (env2 (extend-env | |
6417 | env1 | |
6418 | (symbol-append 'check- name) | |
6419 | (make-name | |
6420 | (symbol-append 'check- name) | |
6421 | (closeall (r++ initial-type-env type)) | |
6422 | #f | |
6423 | 0 | |
6424 | #f | |
6425 | #f | |
6426 | #t | |
6427 | #f | |
6428 | pure | |
6429 | pred | |
6430 | #f | |
6431 | sel)))) | |
6432 | env2)))))) | |
6433 | (define defprim | |
6434 | (lambda (name type mode) | |
6435 | (handle | |
6436 | (r+ initial-type-env type) | |
6437 | (match-lambda* | |
6438 | (('type . args) (apply syntax-err type args)) | |
6439 | (x (apply raise x)))) | |
6440 | (let* ((attr (match mode | |
6441 | ('impure '((i))) | |
6442 | ('pure '()) | |
6443 | ('pure-if-cons-is '((ic))) | |
6444 | ('mutates-cons | |
6445 | (set! cons-mutators (cons name cons-mutators)) | |
6446 | '()) | |
6447 | (x (use-error | |
6448 | "invalid attribute ~a for st:defprim" | |
6449 | x)))) | |
6450 | (info `(,name ,type ,@attr))) | |
6451 | (unless | |
6452 | (equal? info (assq name initial-info)) | |
6453 | (set! initial-info (cons info initial-info)) | |
6454 | (set! initial-env (init-prim info initial-env)))))) | |
6455 | (init-types!) | |
6456 | (init-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?)) | |
6472 | (define %procedure? | |
6473 | (lookup initial-env 'procedure?)) | |
6474 | (define n-unbound 0) | |
6475 | (define bind-defs | |
6476 | (lambda (defs env0 tenv0 old-unbound timestamp) | |
6477 | (letrec ((cons-mutable #f) | |
6478 | (unbound '()) | |
6479 | (use-var | |
6480 | (lambda (x env context mk-node) | |
6481 | (match (lookup? env x) | |
6482 | (#f | |
6483 | (let* ((b (bind-var x)) (n (mk-node b))) | |
6484 | (set-name-timestamp! b context) | |
6485 | (set! unbound (cons n unbound)) | |
6486 | n)) | |
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))) | |
6491 | (mk-node b))))) | |
6492 | (bind-var | |
6493 | (lambda (x) | |
6494 | (make-name | |
6495 | x | |
6496 | #f | |
6497 | timestamp | |
6498 | 0 | |
6499 | #f | |
6500 | #f | |
6501 | #f | |
6502 | #f | |
6503 | #f | |
6504 | #f | |
6505 | #f | |
6506 | #f))) | |
6507 | (bind (lambda (e env tenv context) | |
6508 | (let ((bind-cur (lambda (x) (bind x env tenv context)))) | |
6509 | (match e | |
6510 | (($ var x) (use-var x env context make-var)) | |
6511 | (($ prim x) | |
6512 | (use-var x initial-env context make-var)) | |
6513 | (($ const c pred) | |
6514 | (use-var | |
6515 | pred | |
6516 | initial-env | |
6517 | context | |
6518 | (lambda (p) (make-const c p)))) | |
6519 | (($ lam args e2) | |
6520 | (let* ((b-args (map bind-var args)) | |
6521 | (newenv (extend-env* env args b-args))) | |
6522 | (make-lam | |
6523 | 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)) | |
6528 | (newenv | |
6529 | (extend-env* | |
6530 | env | |
6531 | (cons rest args) | |
6532 | (cons b-rest b-args)))) | |
6533 | (make-vlam | |
6534 | b-args | |
6535 | b-rest | |
6536 | (bind e2 newenv tenv context)))) | |
6537 | (($ match e1 clauses) | |
6538 | (make-match | |
6539 | (bind-cur e1) | |
6540 | (map (lambda (x) | |
6541 | (bind-mclause x env tenv context)) | |
6542 | clauses))) | |
6543 | (($ app e1 args) | |
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) | |
6549 | (make-if | |
6550 | (bind-cur test) | |
6551 | (bind-cur then) | |
6552 | (bind-cur els))) | |
6553 | (($ delay e2) (make-delay (bind-cur e2))) | |
6554 | (($ set! x e2) | |
6555 | (use-var | |
6556 | x | |
6557 | env | |
6558 | context | |
6559 | (lambda (b) | |
6560 | (when (name-struct b) | |
6561 | (syntax-err | |
6562 | (pexpr e) | |
6563 | "define-structure identifier ~a may not be assigned" | |
6564 | x)) | |
6565 | (when (name-primitive b) | |
6566 | (syntax-err | |
6567 | (pexpr e) | |
6568 | "(set! ~a ...) requires (define ~a ...)" | |
6569 | x | |
6570 | x)) | |
6571 | (when (and (not (name-mutated b)) | |
6572 | (not (= (name-timestamp b) | |
6573 | timestamp))) | |
6574 | (syntax-err | |
6575 | (pexpr e) | |
6576 | "(set! ~a ...) missing from compilation unit defining ~a" | |
6577 | x | |
6578 | x)) | |
6579 | (set-name-mutated! b #t) | |
6580 | (make-set! b (bind-cur e2))))) | |
6581 | (($ let args e2) | |
6582 | (let* ((b-args | |
6583 | (map (match-lambda | |
6584 | (($ bind x e) | |
6585 | (make-bind | |
6586 | (bind-var x) | |
6587 | (bind-cur e)))) | |
6588 | args)) | |
6589 | (newenv | |
6590 | (extend-env* | |
6591 | env | |
6592 | (map bind-name args) | |
6593 | (map bind-name b-args)))) | |
6594 | (make-let | |
6595 | b-args | |
6596 | (bind e2 newenv tenv context)))) | |
6597 | (($ let* args e2) | |
6598 | (recur loop | |
6599 | ((args args) (b-args '()) (env env)) | |
6600 | (match args | |
6601 | ((($ bind x e) . rest) | |
6602 | (let ((b (bind-var x))) | |
6603 | (loop rest | |
6604 | (cons (make-bind | |
6605 | b | |
6606 | (bind e | |
6607 | env | |
6608 | tenv | |
6609 | context)) | |
6610 | b-args) | |
6611 | (extend-env env x b)))) | |
6612 | (() | |
6613 | (make-let* | |
6614 | (reverse b-args) | |
6615 | (bind e2 env tenv context)))))) | |
6616 | (($ letr args e2) | |
6617 | (let* ((b-args | |
6618 | (map (match-lambda | |
6619 | (($ bind x e) | |
6620 | (make-bind (bind-var x) e))) | |
6621 | args)) | |
6622 | (newenv | |
6623 | (extend-env* | |
6624 | env | |
6625 | (map bind-name args) | |
6626 | (map bind-name b-args))) | |
6627 | (b-args | |
6628 | (map (match-lambda | |
6629 | (($ bind b e) | |
6630 | (let* ((n (name-occ b)) | |
6631 | (e2 (bind e | |
6632 | newenv | |
6633 | tenv | |
6634 | context))) | |
6635 | (set-name-occ! b n) | |
6636 | (make-bind b e2)))) | |
6637 | b-args))) | |
6638 | (make-letr | |
6639 | b-args | |
6640 | (bind e2 newenv tenv context)))) | |
6641 | (($ body defs exps) | |
6642 | (match-let* | |
6643 | (((defs newenv newtenv) | |
6644 | (bind-defn defs env tenv #f))) | |
6645 | (make-body | |
6646 | defs | |
6647 | (map (lambda (x) | |
6648 | (bind x newenv newtenv context)) | |
6649 | exps)))) | |
6650 | (($ record args) | |
6651 | (make-record | |
6652 | (map (match-lambda | |
6653 | (($ bind x e) | |
6654 | (new-field! x) | |
6655 | (make-bind x (bind-cur e)))) | |
6656 | args))) | |
6657 | (($ field x e2) | |
6658 | (new-field! x) | |
6659 | (make-field x (bind-cur e2))) | |
6660 | (($ cast ty e2) | |
6661 | (match-let | |
6662 | (((t absv) | |
6663 | (handle | |
6664 | (r+collect | |
6665 | tenv | |
6666 | (match ty | |
6667 | (('rec bind ty2) | |
6668 | `(rec ,bind (,ty2 -> ,ty2))) | |
6669 | (_ `(,ty -> ,ty)))) | |
6670 | (match-lambda* | |
6671 | (('type . args) | |
6672 | (apply syntax-err ty args)) | |
6673 | (x (apply raise x)))))) | |
6674 | (make-cast | |
6675 | (list ty t absv) | |
6676 | (bind-cur e2)))))))) | |
6677 | (bind-mclause | |
6678 | (lambda (clause env tenv context) | |
6679 | (match-let* | |
6680 | ((($ mclause pattern body failsym) clause) | |
6681 | (patenv empty-env) | |
6682 | (bp (recur loop | |
6683 | ((p pattern)) | |
6684 | (match p | |
6685 | (($ pvar x) | |
6686 | (when (bound? patenv x) | |
6687 | (syntax-err | |
6688 | (ppat pattern) | |
6689 | "pattern variable ~a repeated" | |
6690 | x)) | |
6691 | (let ((b (bind-var x))) | |
6692 | (set! patenv (extend-env patenv x b)) | |
6693 | (make-pvar b))) | |
6694 | (($ pobj c args) | |
6695 | (use-var | |
6696 | c | |
6697 | env | |
6698 | context | |
6699 | (lambda (b) | |
6700 | (cond ((boolean? (name-predicate b)) | |
6701 | (syntax-err | |
6702 | (ppat pattern) | |
6703 | "~a is not a predicate" | |
6704 | c)) | |
6705 | ((and (not (eq? b %vector?)) | |
6706 | (not (eq? b %cvector?)) | |
6707 | (not (= (length | |
6708 | (cdr (name-predicate | |
6709 | b))) | |
6710 | (length args)))) | |
6711 | (syntax-err | |
6712 | (ppat pattern) | |
6713 | "~a requires ~a sub-patterns" | |
6714 | c | |
6715 | (length | |
6716 | (cdr (name-predicate | |
6717 | b))))) | |
6718 | (else | |
6719 | (make-pobj | |
6720 | b | |
6721 | (map loop args))))))) | |
6722 | (($ pand pats) | |
6723 | (make-pand (map loop pats))) | |
6724 | (($ pnot pat) (make-pnot (loop pat))) | |
6725 | (($ ppred pred) | |
6726 | (use-var | |
6727 | pred | |
6728 | env | |
6729 | context | |
6730 | (lambda (b) | |
6731 | (unless | |
6732 | (name-predicate b) | |
6733 | (syntax-err | |
6734 | (ppat pattern) | |
6735 | "~a is not a predicate" | |
6736 | pred)) | |
6737 | (make-ppred b)))) | |
6738 | (($ pany) p) | |
6739 | (($ pelse) p) | |
6740 | (($ pconst c pred) | |
6741 | (use-var | |
6742 | pred | |
6743 | initial-env | |
6744 | context | |
6745 | (lambda (p) (make-pconst c p)))))))) | |
6746 | (if failsym | |
6747 | (let ((b (bind-var failsym))) | |
6748 | (when (bound? patenv failsym) | |
6749 | (syntax-err | |
6750 | (ppat pattern) | |
6751 | "fail symbol ~a repeated" | |
6752 | failsym)) | |
6753 | (set! patenv (extend-env patenv failsym b)) | |
6754 | (make-mclause | |
6755 | bp | |
6756 | (bind body (join-env env patenv) tenv context) | |
6757 | b)) | |
6758 | (make-mclause | |
6759 | bp | |
6760 | (bind body (join-env env patenv) tenv context) | |
6761 | #f))))) | |
6762 | (bind-defn | |
6763 | (lambda (defs env tenv glob) | |
6764 | (let* ((newenv empty-env) | |
6765 | (newtenv empty-env) | |
6766 | (struct-def | |
6767 | (lambda (x pure) | |
6768 | (when (or (bound? newenv x) | |
6769 | (and glob (bound? initial-env x))) | |
6770 | (syntax-err | |
6771 | #f | |
6772 | "~a defined more than once" | |
6773 | x)) | |
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)) | |
6779 | b))) | |
6780 | (bind1 (match-lambda | |
6781 | ((and z ($ define x e)) | |
6782 | (cond ((not x) z) | |
6783 | ((bound? newenv x) | |
6784 | (if glob | |
6785 | (make-define #f (make-set! x e)) | |
6786 | (syntax-err | |
6787 | #f | |
6788 | "~a defined more than once" | |
6789 | x))) | |
6790 | (else | |
6791 | (let ((b (bind-var x))) | |
6792 | (set-name-gdef! b glob) | |
6793 | (set! newenv | |
6794 | (extend-env newenv x b)) | |
6795 | (make-define b e))))) | |
6796 | ((and d | |
6797 | ($ defstruct | |
6798 | tag | |
6799 | args | |
6800 | make | |
6801 | pred | |
6802 | get | |
6803 | set | |
6804 | getn | |
6805 | setn | |
6806 | mutable)) | |
6807 | (let* ((make (struct-def | |
6808 | make | |
6809 | (map not mutable))) | |
6810 | (pred (struct-def pred #t)) | |
6811 | (bind-get | |
6812 | (lambda (name n) | |
6813 | (match name | |
6814 | (($ some x) | |
6815 | (let ((b (struct-def | |
6816 | x | |
6817 | #t))) | |
6818 | (set-name-selector! | |
6819 | b | |
6820 | (lambda (x) | |
6821 | (make-pobj | |
6822 | pred | |
6823 | (map-with-n | |
6824 | (lambda (_ m) | |
6825 | (if (= m n) | |
6826 | x | |
6827 | (make-pany))) | |
6828 | get)))) | |
6829 | (some b))) | |
6830 | (none none)))) | |
6831 | (bind-set | |
6832 | (match-lambda | |
6833 | (($ some x) | |
6834 | (some (struct-def x #t))) | |
6835 | (none none))) | |
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) | |
6841 | (syntax-err | |
6842 | (pdef d) | |
6843 | "type constructor ~a defined more than once" | |
6844 | tag))) | |
6845 | (tc (bind-tycon | |
6846 | tag | |
6847 | mutable | |
6848 | (bound? tenv tag) | |
6849 | (lambda args | |
6850 | (apply syntax-err | |
6851 | (cons (pdef d) | |
6852 | args)))))) | |
6853 | (set! newtenv (extend-env newtenv tag tc)) | |
6854 | (set-name-predicate! | |
6855 | pred | |
6856 | `(,tc ,@(map (lambda (_) (gensym)) get))) | |
6857 | (make-defstruct | |
6858 | tc | |
6859 | args | |
6860 | make | |
6861 | pred | |
6862 | get | |
6863 | set | |
6864 | getn | |
6865 | setn | |
6866 | mutable))) | |
6867 | ((and d ($ datatype dt)) | |
6868 | (make-datatype | |
6869 | (maplr (match-lambda | |
6870 | (((tag . args) . bindings) | |
6871 | (when (bound? newtenv tag) | |
6872 | (syntax-err | |
6873 | (pdef d) | |
6874 | "type constructor ~a defined more than once" | |
6875 | tag)) | |
6876 | (let ((tc (bind-tycon | |
6877 | tag | |
6878 | (map (lambda (_) #f) | |
6879 | args) | |
6880 | (bound? tenv tag) | |
6881 | (lambda args | |
6882 | (apply syntax-err | |
6883 | (cons (pdef d) | |
6884 | args)))))) | |
6885 | (set! newtenv | |
6886 | (extend-env newtenv tag tc)) | |
6887 | (cons (cons tc args) | |
6888 | (maplr (match-lambda | |
6889 | (($ variant | |
6890 | con | |
6891 | pred | |
6892 | arg-types) | |
6893 | (let ((make (struct-def | |
6894 | con | |
6895 | #t)) | |
6896 | (pred (struct-def | |
6897 | pred | |
6898 | #t))) | |
6899 | (set-name-predicate! | |
6900 | pred | |
6901 | (cons tc | |
6902 | args)) | |
6903 | (set-name-variant! | |
6904 | pred | |
6905 | arg-types) | |
6906 | (make-variant | |
6907 | make | |
6908 | pred | |
6909 | arg-types)))) | |
6910 | bindings))))) | |
6911 | dt))))) | |
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))) | |
6917 | (=> fail) | |
6918 | (if (eq? (name-name x) y) | |
6919 | (if (bound? initial-env y) | |
6920 | (make-define | |
6921 | x | |
6922 | (make-var (lookup initial-env y))) | |
6923 | (begin | |
6924 | (printf | |
6925 | "Warning: (define ~a ~a) but ~a is not a primitive~%" | |
6926 | y | |
6927 | y | |
6928 | y) | |
6929 | (fail))) | |
6930 | (fail))) | |
6931 | ((and ($ define x e2) context) | |
6932 | (when (and glob | |
6933 | (name? x) | |
6934 | (bound? | |
6935 | initial-env | |
6936 | (name-name x))) | |
6937 | (printf | |
6938 | "Note: (define ~a ...) hides primitive ~a~%" | |
6939 | (name-name x) | |
6940 | (name-name x))) | |
6941 | (make-define | |
6942 | (or x | |
6943 | (let ((b (bind-var x))) | |
6944 | (set-name-gdef! b glob) | |
6945 | b)) | |
6946 | (bind e2 newenv2 newtenv2 context))) | |
6947 | (d d)))) | |
6948 | (list (maplr bind2 defs2) newenv2 newtenv2)))) | |
6949 | (bind-old | |
6950 | (lambda (e env) | |
6951 | (match e | |
6952 | (($ var x) | |
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)))) | |
6960 | (($ set! x _) | |
6961 | (match (lookup? env (name-name x)) | |
6962 | (#f (set! unbound (cons e unbound))) | |
6963 | (b (when (name-struct b) | |
6964 | (syntax-err | |
6965 | (pexpr e) | |
6966 | "define-structure identifier ~a may not be assigned" | |
6967 | x)) | |
6968 | (when (name-primitive b) | |
6969 | (syntax-err | |
6970 | (pexpr e) | |
6971 | "(set! ~a ...) requires (define ~a ...)" | |
6972 | x | |
6973 | x)) | |
6974 | (when (and (not (name-mutated b)) | |
6975 | (not (= (name-timestamp b) | |
6976 | timestamp))) | |
6977 | (syntax-err | |
6978 | (pexpr e) | |
6979 | "(set! ~a ...) missing from compilation unit defining ~a" | |
6980 | x | |
6981 | x)) | |
6982 | (set-name-mutated! b #t) | |
6983 | (set-name-occ! b (+ 1 (name-occ b))) | |
6984 | (set-set!-name! e b)))))))) | |
6985 | (match-let | |
6986 | (((defs env tenv) (bind-defn defs env0 tenv0 #t))) | |
6987 | (for-each | |
6988 | (lambda (x) (bind-old x env)) | |
6989 | old-unbound) | |
6990 | (set-cons-mutability! cons-mutable) | |
6991 | (set! n-unbound (length unbound)) | |
6992 | (list defs env tenv unbound))))) | |
6993 | (define rebind-var | |
6994 | (lambda (b) | |
6995 | (make-name | |
6996 | (name-name b) | |
6997 | (name-ty b) | |
6998 | (name-timestamp b) | |
6999 | (name-occ b) | |
7000 | (name-mutated b) | |
7001 | #f | |
7002 | #f | |
7003 | #f | |
7004 | #f | |
7005 | #f | |
7006 | #f | |
7007 | #f))) | |
7008 | (define warn-unbound | |
7009 | (lambda (l) | |
7010 | (let* ((names '()) | |
7011 | (node->name | |
7012 | (match-lambda | |
7013 | (($ var x) x) | |
7014 | (($ set! x _) x) | |
7015 | (($ pobj x _) x) | |
7016 | (($ ppred x) x))) | |
7017 | (warn (lambda (b) | |
7018 | (unless | |
7019 | (memq (name-name b) names) | |
7020 | (set! names (cons (name-name b) names)) | |
7021 | (printf | |
7022 | "Warning: ~a is unbound in " | |
7023 | (name-name b)) | |
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 | |
7029 | (lambda (defs) | |
7030 | (map (match-lambda | |
7031 | (($ define x e2) (make-define x (improve e2))) | |
7032 | (x x)) | |
7033 | defs))) | |
7034 | (define improve | |
7035 | (match-lambda | |
7036 | (($ match e clauses) (improve-match e clauses)) | |
7037 | (($ if tst thn els) (improve-if tst thn els)) | |
7038 | ((? var? e) e) | |
7039 | ((? const? e) e) | |
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?) | |
7049 | args) | |
7050 | (make-app e1 args)))) | |
7051 | (($ 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))) | |
7058 | (($ let args e2) | |
7059 | (let ((args (map (match-lambda | |
7060 | (($ bind x e) (make-bind x (improve e)))) | |
7061 | args))) | |
7062 | (make-let args (improve e2)))) | |
7063 | (($ let* args e2) | |
7064 | (let ((args (map (match-lambda | |
7065 | (($ bind x e) (make-bind x (improve e)))) | |
7066 | args))) | |
7067 | (make-let* args (improve e2)))) | |
7068 | (($ letr args e2) | |
7069 | (let ((args (map (match-lambda | |
7070 | (($ bind x e) (make-bind x (improve e)))) | |
7071 | args))) | |
7072 | (make-letr args (improve e2)))) | |
7073 | (($ body defs exps) | |
7074 | (let ((defs (improve-defs defs))) | |
7075 | (make-body defs (map improve exps)))) | |
7076 | (($ record args) | |
7077 | (make-record | |
7078 | (map (match-lambda | |
7079 | (($ bind x e) (make-bind x (improve e)))) | |
7080 | args))) | |
7081 | (($ field x e2) (make-field x (improve e2))) | |
7082 | (($ cast ty e2) (make-cast ty (improve e2))))) | |
7083 | (define improve-if | |
7084 | (lambda (tst thn els) | |
7085 | (let ((if->match | |
7086 | (lambda (x p mk-s thn els) | |
7087 | (let ((else-pat | |
7088 | (match els | |
7089 | (($ app ($ var q) _) | |
7090 | (if (eq? q %should-never-reach) | |
7091 | (make-pelse) | |
7092 | (make-pany))) | |
7093 | (_ (make-pany))))) | |
7094 | (make-match | |
7095 | (make-var x) | |
7096 | (list (make-mclause | |
7097 | (mk-s (make-ppred p)) | |
7098 | (make-body '() (list thn)) | |
7099 | #f) | |
7100 | (make-mclause | |
7101 | (mk-s else-pat) | |
7102 | (make-body '() (list els)) | |
7103 | #f))))))) | |
7104 | (match tst | |
7105 | (($ app ($ var v) (e)) | |
7106 | (=> fail) | |
7107 | (if (eq? v %not) (improve-if e els thn) (fail))) | |
7108 | (($ app ($ var eq) (($ const #f _) val)) | |
7109 | (=> fail) | |
7110 | (if (or (eq? eq %eq?) | |
7111 | (eq? eq %eqv?) | |
7112 | (eq? eq %equal?)) | |
7113 | (improve-if val els thn) | |
7114 | (fail))) | |
7115 | (($ app ($ var eq) (val ($ const #f _))) | |
7116 | (=> fail) | |
7117 | (if (or (eq? eq %eq?) | |
7118 | (eq? eq %eqv?) | |
7119 | (eq? eq %equal?)) | |
7120 | (improve-if val els thn) | |
7121 | (fail))) | |
7122 | (($ app ($ var v) (($ var x))) | |
7123 | (=> fail) | |
7124 | (if (and (name-predicate v) (not (name-mutated x))) | |
7125 | (improve (if->match x v (lambda (x) x) thn els)) | |
7126 | (fail))) | |
7127 | (($ app ($ var v) (($ app ($ var s) (($ var x))))) | |
7128 | (=> fail) | |
7129 | (if (and (name-predicate v) | |
7130 | (name-selector s) | |
7131 | (not (name-mutated x))) | |
7132 | (improve | |
7133 | (if->match x v (name-selector s) thn els)) | |
7134 | (fail))) | |
7135 | (($ app ($ var v) (($ var x))) | |
7136 | (=> fail) | |
7137 | (if (and (name-selector v) (not (name-mutated x))) | |
7138 | (improve | |
7139 | (if->match | |
7140 | x | |
7141 | %false-object? | |
7142 | (name-selector v) | |
7143 | els | |
7144 | thn)) | |
7145 | (fail))) | |
7146 | (($ var v) | |
7147 | (=> fail) | |
7148 | (if (not (name-mutated v)) | |
7149 | (improve | |
7150 | (if->match | |
7151 | v | |
7152 | %false-object? | |
7153 | (lambda (x) x) | |
7154 | els | |
7155 | thn)) | |
7156 | (fail))) | |
7157 | (_ (make-if | |
7158 | (improve tst) | |
7159 | (improve thn) | |
7160 | (improve els))))))) | |
7161 | (define improve-match | |
7162 | (lambda (e clauses) | |
7163 | (let ((clauses | |
7164 | (map (match-lambda | |
7165 | (($ mclause p body fail) | |
7166 | (make-mclause p (improve body) fail))) | |
7167 | clauses))) | |
7168 | (match e | |
7169 | (($ var x) | |
7170 | (if (not (name-mutated x)) | |
7171 | (let ((fix-clause | |
7172 | (match-lambda | |
7173 | ((and c ($ mclause p e fail)) | |
7174 | (if (not (uses-x? e x)) | |
7175 | c | |
7176 | (let ((y (rebind-var x))) | |
7177 | (make-mclause | |
7178 | (make-flat-pand (list p (make-pvar y))) | |
7179 | (sub e x y) | |
7180 | fail))))))) | |
7181 | (make-match e (map fix-clause clauses))) | |
7182 | (make-match e clauses))) | |
7183 | (_ (make-match (improve e) clauses)))))) | |
7184 | (define uses-x? | |
7185 | (lambda (e x) | |
7186 | (recur loop | |
7187 | ((e e)) | |
7188 | (match e | |
7189 | (($ and exps) (ormap loop exps)) | |
7190 | (($ app fun args) | |
7191 | (or (loop fun) (ormap loop args))) | |
7192 | (($ begin exps) (ormap loop exps)) | |
7193 | (($ if e1 e2 e3) | |
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))) | |
7198 | bindings) | |
7199 | (loop body))) | |
7200 | (($ let* bindings body) | |
7201 | (or (ormap (match-lambda (($ bind _ b) (loop b))) | |
7202 | bindings) | |
7203 | (loop body))) | |
7204 | (($ letr bindings body) | |
7205 | (or (ormap (match-lambda (($ bind _ b) (loop b))) | |
7206 | bindings) | |
7207 | (loop body))) | |
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) | |
7214 | (or (loop exp) | |
7215 | (ormap (match-lambda | |
7216 | (($ mclause p b _) (or (loop p) (loop b)))) | |
7217 | clauses))) | |
7218 | (($ body defs exps) | |
7219 | (or (ormap loop defs) (ormap loop exps))) | |
7220 | (($ record bindings) | |
7221 | (ormap (match-lambda (($ bind _ b) (loop b))) | |
7222 | bindings)) | |
7223 | (($ field _ e) (loop e)) | |
7224 | (($ cast _ e) (loop e)) | |
7225 | (($ define _ e) (loop e)) | |
7226 | ((? defstruct?) #f) | |
7227 | ((? datatype?) #f) | |
7228 | (($ pand pats) (ormap loop pats)) | |
7229 | (($ pnot pat) (loop pat)) | |
7230 | (($ pobj c args) (ormap loop args)) | |
7231 | (($ ppred pred) (eq? x pred)) | |
7232 | (_ #f))))) | |
7233 | (define sub | |
7234 | (lambda (e x to) | |
7235 | (let ((dos (lambda (y) (if (eq? x y) to y)))) | |
7236 | (recur sub | |
7237 | ((e e)) | |
7238 | (match e | |
7239 | (($ define x e) (make-define x (sub e))) | |
7240 | ((? defstruct?) e) | |
7241 | ((? datatype?) e) | |
7242 | (($ match e clauses) | |
7243 | (let ((clauses | |
7244 | (map (match-lambda | |
7245 | (($ mclause p e fail) | |
7246 | (make-mclause p (sub e) fail))) | |
7247 | clauses))) | |
7248 | (make-match (sub e) clauses))) | |
7249 | (($ if tst thn els) | |
7250 | (make-if (sub tst) (sub thn) (sub els))) | |
7251 | (($ var x) (make-var (dos x))) | |
7252 | ((? const? e) e) | |
7253 | (($ lam args e2) (make-lam args (sub e2))) | |
7254 | (($ vlam args rest e2) | |
7255 | (make-vlam args rest (sub e2))) | |
7256 | (($ app e1 args) | |
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))) | |
7263 | (($ let args e2) | |
7264 | (let ((args (map (match-lambda | |
7265 | (($ bind x e) (make-bind x (sub e)))) | |
7266 | args))) | |
7267 | (make-let args (sub e2)))) | |
7268 | (($ let* args e2) | |
7269 | (let ((args (map (match-lambda | |
7270 | (($ bind x e) (make-bind x (sub e)))) | |
7271 | args))) | |
7272 | (make-let* args (sub e2)))) | |
7273 | (($ letr args e2) | |
7274 | (let ((args (map (match-lambda | |
7275 | (($ bind x e) (make-bind x (sub e)))) | |
7276 | args))) | |
7277 | (make-letr args (sub e2)))) | |
7278 | (($ body defs exps) | |
7279 | (make-body (map sub defs) (map sub exps))) | |
7280 | (($ record args) | |
7281 | (make-record | |
7282 | (map (match-lambda | |
7283 | (($ bind x e) (make-bind x (sub e)))) | |
7284 | args))) | |
7285 | (($ field x e) (make-field x (sub e))) | |
7286 | (($ cast ty e) (make-cast ty (sub e)))))))) | |
7287 | (define improve-clauses | |
7288 | (lambda (clauses) | |
7289 | (recur loop | |
7290 | ((clauses clauses)) | |
7291 | (match clauses | |
7292 | (() '()) | |
7293 | ((_) clauses) | |
7294 | (((and m1 ($ mclause p _ fail)) . rest) | |
7295 | (cons m1 | |
7296 | (if fail | |
7297 | (loop rest) | |
7298 | (recur loop2 | |
7299 | ((clauses (loop rest))) | |
7300 | (match clauses | |
7301 | (() '()) | |
7302 | (((and m ($ mclause p2 body2 fail2)) | |
7303 | . | |
7304 | r) | |
7305 | (match (improve-by-pattern p2 p) | |
7306 | (('stop . p) | |
7307 | (cons (make-mclause | |
7308 | p | |
7309 | body2 | |
7310 | fail2) | |
7311 | r)) | |
7312 | (('redundant . p) | |
7313 | (unless | |
7314 | (null? r) | |
7315 | (printf | |
7316 | "Warning: redundant pattern ~a~%" | |
7317 | (ppat p2))) | |
7318 | (cons (make-mclause | |
7319 | p | |
7320 | body2 | |
7321 | fail2) | |
7322 | r)) | |
7323 | (('continue . p) | |
7324 | (cons (make-mclause | |
7325 | p | |
7326 | body2 | |
7327 | fail2) | |
7328 | (loop2 r)))))))))))))) | |
7329 | (define improve-by-pattern | |
7330 | (lambda (p2 p1) | |
7331 | (call-with-current-continuation | |
7332 | (lambda (k) | |
7333 | (let* ((reject (lambda () (k (cons 'continue p2)))) | |
7334 | (p1covers #t) | |
7335 | (p2covers #t) | |
7336 | (p3 (recur m | |
7337 | ((p1 p1) (p2 p2)) | |
7338 | '(printf "(M ~a ~a)~%" (ppat p1) (ppat p2)) | |
7339 | (match (cons p1 p2) | |
7340 | ((($ pand (a . _)) . p2) (m a p2)) | |
7341 | ((p1 $ pand (a . b)) | |
7342 | (make-flat-pand (cons (m p1 a) b))) | |
7343 | ((($ pvar _) . _) | |
7344 | (unless | |
7345 | (or (pvar? p2) (pany? p2)) | |
7346 | (set! p2covers #f)) | |
7347 | p2) | |
7348 | ((($ pany) . _) | |
7349 | (unless | |
7350 | (or (pvar? p2) (pany? p2)) | |
7351 | (set! p2covers #f)) | |
7352 | p2) | |
7353 | ((($ pelse) . _) | |
7354 | '(unless | |
7355 | (or (pvar? p2) (pany? p2)) | |
7356 | (set! p2covers #f)) | |
7357 | p2) | |
7358 | ((_ $ pvar _) | |
7359 | (unless p1covers (reject)) | |
7360 | (set! p1covers #f) | |
7361 | (make-flat-pand (list p2 (make-pnot p1)))) | |
7362 | ((_ $ pany) | |
7363 | (unless p1covers (reject)) | |
7364 | (set! p1covers #f) | |
7365 | (make-flat-pand (list p2 (make-pnot p1)))) | |
7366 | ((_ $ pelse) | |
7367 | (unless p1covers (reject)) | |
7368 | (set! p1covers #f) | |
7369 | (make-flat-pand (list p2 (make-pnot p1)))) | |
7370 | ((($ pconst a _) $ pconst b _) | |
7371 | (unless (equal? a b) (reject)) | |
7372 | p2) | |
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)) | |
7378 | p2) | |
7379 | ((($ ppred tag1) $ pobj tag2 _) | |
7380 | (unless (eq? tag1 tag2) (reject)) | |
7381 | (set! p2covers #f) | |
7382 | p2) | |
7383 | ((($ ppred tag1) $ pconst c tag2) | |
7384 | (unless (eq? tag1 tag2) (reject)) | |
7385 | (set! p2covers #f) | |
7386 | p2) | |
7387 | (_ (reject)))))) | |
7388 | (cond (p1covers (cons 'redundant p2)) | |
7389 | (p2covers (cons 'stop p3)) | |
7390 | (else (cons 'continue p3)))))))) | |
7391 | (define improve-by-noisily | |
7392 | (lambda (p2 p1) | |
7393 | (let ((r (improve-by-pattern p2 p1))) | |
7394 | (printf | |
7395 | "~a by ~a returns ~a ~a~%" | |
7396 | (ppat p2) | |
7397 | (ppat p1) | |
7398 | (car r) | |
7399 | (ppat (cdr r)))))) | |
7400 | (define make-components | |
7401 | (lambda (d) | |
7402 | (let* ((structs | |
7403 | (filter-map | |
7404 | (match-lambda ((? define?) #f) (x x)) | |
7405 | d)) | |
7406 | (defs (filter-map | |
7407 | (match-lambda ((? define? x) x) (_ #f)) | |
7408 | d)) | |
7409 | (name-of (match-lambda (($ define x _) x))) | |
7410 | (ref-of | |
7411 | (match-lambda | |
7412 | (($ define _ e) (references e name-gdef)))) | |
7413 | (comp (top-sort defs name-of ref-of))) | |
7414 | (when #f | |
7415 | (printf "Components:~%") | |
7416 | (pretty-print | |
7417 | (map (lambda (c) | |
7418 | (map (match-lambda | |
7419 | (($ define x _) (and x (name-name x)))) | |
7420 | c)) | |
7421 | comp))) | |
7422 | (append structs comp)))) | |
7423 | (define make-body-components | |
7424 | (lambda (d) | |
7425 | (let* ((structs | |
7426 | (filter-map | |
7427 | (match-lambda ((? define?) #f) (x x)) | |
7428 | d)) | |
7429 | (defs (filter-map | |
7430 | (match-lambda ((? define? x) x) (_ #f)) | |
7431 | d)) | |
7432 | (name-of (match-lambda (($ define x _) x))) | |
7433 | (bound (map name-of defs)) | |
7434 | (ref-of | |
7435 | (match-lambda | |
7436 | (($ define _ e) | |
7437 | (references e (lambda (x) (memq x bound)))))) | |
7438 | (comp (top-sort defs name-of ref-of))) | |
7439 | (when #f | |
7440 | (printf "Components:~%") | |
7441 | (pretty-print | |
7442 | (map (lambda (c) | |
7443 | (map (match-lambda | |
7444 | (($ define x _) (and x (name-name x)))) | |
7445 | c)) | |
7446 | comp))) | |
7447 | (append structs comp)))) | |
7448 | (define make-letrec-components | |
7449 | (lambda (bindings) | |
7450 | (let* ((name-of bind-name) | |
7451 | (bound (map name-of bindings)) | |
7452 | (ref-of | |
7453 | (match-lambda | |
7454 | (($ bind _ e) | |
7455 | (references e (lambda (x) (memq x bound)))))) | |
7456 | (comp (top-sort bindings name-of ref-of))) | |
7457 | (when #f | |
7458 | (printf "Letrec Components:~%") | |
7459 | (pretty-print | |
7460 | (map (lambda (c) | |
7461 | (map (match-lambda (($ bind x _) (pname x))) c)) | |
7462 | comp))) | |
7463 | comp))) | |
7464 | (define references | |
7465 | (lambda (e ref?) | |
7466 | (recur loop | |
7467 | ((e e)) | |
7468 | (match e | |
7469 | (($ define x e) | |
7470 | (if (and x (name-mutated x)) | |
7471 | (union (set x) (loop e)) | |
7472 | (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)) | |
7479 | (($ app e0 args) | |
7480 | (foldr union2 (loop e0) (map loop args))) | |
7481 | (($ let b e2) | |
7482 | (let ((do-bind (match-lambda (($ bind _ e) (loop e))))) | |
7483 | (foldr union2 (loop e2) (map do-bind b)))) | |
7484 | (($ let* b e2) | |
7485 | (let ((do-bind (match-lambda (($ bind _ e) (loop e))))) | |
7486 | (foldr union2 (loop e2) (map do-bind b)))) | |
7487 | (($ letr b e2) | |
7488 | (let ((do-bind (match-lambda (($ bind _ e) (loop e))))) | |
7489 | (foldr union2 (loop e2) (map do-bind b)))) | |
7490 | (($ body defs exps) | |
7491 | (foldr union2 | |
7492 | empty-set | |
7493 | (map loop (append defs exps)))) | |
7494 | (($ record b) | |
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)) | |
7499 | (($ and exps) | |
7500 | (foldr union2 empty-set (map loop exps))) | |
7501 | (($ or exps) | |
7502 | (foldr union2 empty-set (map loop exps))) | |
7503 | (($ begin 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)) | |
7508 | (($ set! x body) | |
7509 | (union (if (ref? x) (set x) empty-set) | |
7510 | (loop body))) | |
7511 | (($ match exp clauses) | |
7512 | (foldr union2 | |
7513 | (loop exp) | |
7514 | (map (match-lambda (($ mclause _ exp _) (loop exp))) | |
7515 | clauses))))))) | |
7516 | (define top-sort | |
7517 | (lambda (graph name-of references-of) | |
7518 | (let* ((adj assq) | |
7519 | (g (map (lambda (x) | |
7520 | (list (name-of x) | |
7521 | (box (references-of x)) | |
7522 | (box #f) | |
7523 | x)) | |
7524 | graph)) | |
7525 | (gt (let ((gt (map (match-lambda | |
7526 | ((n _ _ name) | |
7527 | (list n (box empty-set) (box #f) n))) | |
7528 | g))) | |
7529 | (for-each | |
7530 | (match-lambda | |
7531 | ((n nay _ _) | |
7532 | (for-each | |
7533 | (lambda (v) | |
7534 | (match (adj v gt) | |
7535 | (#f #f) | |
7536 | ((_ b _ _) (set-box! b (cons n (unbox b)))))) | |
7537 | (unbox nay)))) | |
7538 | g) | |
7539 | gt)) | |
7540 | (visit (lambda (vg) | |
7541 | (letrec ((visit (lambda (g l) | |
7542 | (match g | |
7543 | (#f l) | |
7544 | ((n nay mark name) | |
7545 | (if (unbox mark) | |
7546 | l | |
7547 | (begin | |
7548 | (set-box! mark #t) | |
7549 | (cons name | |
7550 | (foldr (lambda (v l) | |
7551 | (visit (adj v | |
7552 | vg) | |
7553 | l)) | |
7554 | l | |
7555 | (unbox nay)))))))))) | |
7556 | visit))) | |
7557 | (visit-gt (visit gt)) | |
7558 | (visit-g (visit g)) | |
7559 | (post (foldr visit-gt '() gt)) | |
7560 | (pre (foldl (lambda (gg l) | |
7561 | (match (visit-g (adj gg g) '()) | |
7562 | (() l) | |
7563 | (c (cons c l)))) | |
7564 | '() | |
7565 | post))) | |
7566 | (reverse pre)))) | |
7567 | (define genlet #t) | |
7568 | (define genmatch #t) | |
7569 | (define letonce #f) | |
7570 | (define type-defs | |
7571 | (lambda (d) | |
7572 | (for-each | |
7573 | (match-lambda | |
7574 | ((? defstruct? b) (type-structure b)) | |
7575 | ((? datatype? b) (type-structure b)) | |
7576 | (c (type-component c #t))) | |
7577 | (make-components d)) | |
7578 | (close '()))) | |
7579 | (define type-structure | |
7580 | (match-lambda | |
7581 | (($ defstruct | |
7582 | x | |
7583 | _ | |
7584 | make | |
7585 | pred | |
7586 | get | |
7587 | set | |
7588 | getn | |
7589 | setn | |
7590 | mutable) | |
7591 | (let* ((vars (map (lambda (_) (gensym)) get)) | |
7592 | (make-get-type | |
7593 | (lambda (getter v) | |
7594 | (match getter | |
7595 | (($ some b) | |
7596 | (set-name-ty! | |
7597 | b | |
7598 | (closeall | |
7599 | (r+ initial-type-env `((,x ,@vars) -> ,v))))) | |
7600 | (_ #f)))) | |
7601 | (make-set-type | |
7602 | (lambda (setter v) | |
7603 | (match setter | |
7604 | (($ some b) | |
7605 | (set-name-ty! | |
7606 | b | |
7607 | (closeall | |
7608 | (r+ initial-type-env `((,x ,@vars) ,v -> void))))) | |
7609 | (_ #f))))) | |
7610 | (set-name-ty! | |
7611 | make | |
7612 | (closeall | |
7613 | (r+ initial-type-env `(,@vars -> (,x ,@vars))))) | |
7614 | (set-name-ty! | |
7615 | pred | |
7616 | (closeall | |
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))) | |
7623 | (($ datatype dt) | |
7624 | (for-each | |
7625 | (match-lambda | |
7626 | ((type . variants) | |
7627 | (for-each | |
7628 | (match-lambda | |
7629 | (($ variant con pred arg-types) | |
7630 | (set-name-ty! | |
7631 | con | |
7632 | (closeall | |
7633 | (r+ initial-type-env | |
7634 | `(,@(cdr arg-types) -> ,type)))) | |
7635 | (set-name-ty! | |
7636 | pred | |
7637 | (closeall | |
7638 | (r+ initial-type-env | |
7639 | `((+ ,(name-predicate pred) x) -> bool)))))) | |
7640 | variants))) | |
7641 | dt)))) | |
7642 | (define type-component | |
7643 | (lambda (component top) | |
7644 | (when verbose | |
7645 | (let ((cnames | |
7646 | (filter-map | |
7647 | (match-lambda (($ define b _) (name-name b))) | |
7648 | component))) | |
7649 | (unless | |
7650 | (null? cnames) | |
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))) | |
7655 | component)) | |
7656 | (f1 (match-lambda | |
7657 | (($ define b _) (set-name-ty! b (tvar))))) | |
7658 | (f2 (match-lambda | |
7659 | ((and d ($ define b e)) | |
7660 | (set-define-exp! d (w e names))))) | |
7661 | (f3 (match-lambda | |
7662 | (($ define b e) (unify (name-ty b) (typeof e))))) | |
7663 | (f4 (match-lambda (($ define b _) (name-ty b)))) | |
7664 | (f5 (lambda (d ts) | |
7665 | (match d (($ define b _) (set-name-ty! b ts)))))) | |
7666 | (push-level) | |
7667 | (for-each f1 component) | |
7668 | (for-each f2 component) | |
7669 | (for-each f3 component) | |
7670 | (for-each limit-expansive component) | |
7671 | (for-each | |
7672 | f5 | |
7673 | component | |
7674 | (close (map f4 component))) | |
7675 | (pop-level)))) | |
7676 | (define w | |
7677 | (lambda (e component) | |
7678 | (match e | |
7679 | (($ const _ pred) | |
7680 | (make-type | |
7681 | (r+ initial-type-env (name-predicate pred)) | |
7682 | e)) | |
7683 | (($ var x) | |
7684 | (unless | |
7685 | (name-ty x) | |
7686 | (set-name-ty! | |
7687 | x | |
7688 | (if (name-mutated x) | |
7689 | (monotvar) | |
7690 | (let* ((_1 (push-level)) | |
7691 | (t (closeall (tvar))) | |
7692 | (_2 (pop-level))) | |
7693 | t)))) | |
7694 | (if (ts? (name-ty x)) | |
7695 | (match-let* | |
7696 | ((tynode (make-type #f #f)) | |
7697 | ((t absv) (instantiate (name-ty x) tynode))) | |
7698 | (set-type-ty! tynode t) | |
7699 | (set-type-exp! | |
7700 | tynode | |
7701 | (match (name-primitive x) | |
7702 | ('imprecise | |
7703 | (make-check (list absv #f #f #f component) e)) | |
7704 | ('check | |
7705 | (make-check | |
7706 | (list (cons top absv) #f #f #f component) | |
7707 | e)) | |
7708 | ('nocheck e) | |
7709 | (#t | |
7710 | (make-check | |
7711 | (list absv (mk-definite-prim t) #f #f component) | |
7712 | e)) | |
7713 | (#f | |
7714 | (make-check (list absv #f #f #t component) e)))) | |
7715 | tynode) | |
7716 | e)) | |
7717 | (($ lam x e1) | |
7718 | (for-each (lambda (b) (set-name-ty! b (tvar))) x) | |
7719 | (match-let* | |
7720 | ((body (w e1 component)) | |
7721 | ((t absv) | |
7722 | (r+collect | |
7723 | initial-type-env | |
7724 | `(,@(map name-ty x) -> ,(typeof body))))) | |
7725 | (make-type | |
7726 | t | |
7727 | (make-check | |
7728 | (list absv (mk-definite-lam t) #f #f component) | |
7729 | (make-lam x body))))) | |
7730 | (($ vlam x rest e1) | |
7731 | (for-each (lambda (b) (set-name-ty! b (tvar))) x) | |
7732 | (match-let* | |
7733 | ((z (tvar)) | |
7734 | (_ (set-name-ty! | |
7735 | rest | |
7736 | (r+ initial-type-env `(list ,z)))) | |
7737 | (body (w e1 component)) | |
7738 | ((t absv) | |
7739 | (r+collect | |
7740 | initial-type-env | |
7741 | `(,@(map name-ty x) (&list ,z) -> ,(typeof body))))) | |
7742 | (make-type | |
7743 | t | |
7744 | (make-check | |
7745 | (list absv (mk-definite-lam t) #f #f component) | |
7746 | (make-vlam x rest body))))) | |
7747 | (($ app e0 args) | |
7748 | (match-let* | |
7749 | ((t0 (w e0 component)) | |
7750 | (targs (maplr (lambda (e) (w e component)) args)) | |
7751 | (a* (map (lambda (_) (tvar)) args)) | |
7752 | (b (tvar)) | |
7753 | ((t absv) | |
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)) | |
7760 | (make-type | |
7761 | b | |
7762 | (make-check | |
7763 | (list absv definf #f #f component) | |
7764 | (make-app t0 targs)))))) | |
7765 | (($ let b e2) | |
7766 | (let* ((do-bind | |
7767 | (match-lambda | |
7768 | (($ bind b e) | |
7769 | (if genlet | |
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))))) | |
7775 | (pop-level) | |
7776 | bind) | |
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))) | |
7783 | (($ let* b e2) | |
7784 | (let* ((do-bind | |
7785 | (match-lambda | |
7786 | (($ bind b e) | |
7787 | (if genlet | |
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))))) | |
7793 | (pop-level) | |
7794 | bind) | |
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))) | |
7801 | (($ letr b e2) | |
7802 | (let* ((do-comp | |
7803 | (lambda (b) | |
7804 | (if genlet | |
7805 | (let* ((f1 (match-lambda | |
7806 | (($ bind b _) (set-name-ty! b (tvar))))) | |
7807 | (names (map (match-lambda | |
7808 | (($ bind b _) (pname b))) | |
7809 | b)) | |
7810 | (f2 (match-lambda | |
7811 | (($ bind b e) | |
7812 | (make-bind b (w e names))))) | |
7813 | (f3 (match-lambda | |
7814 | (($ bind b e) | |
7815 | (unify (name-ty b) (typeof e)) | |
7816 | (name-ty b)))) | |
7817 | (f4 (lambda (bind ts) | |
7818 | (match bind | |
7819 | (($ bind b _) | |
7820 | (set-name-ty! b ts))))) | |
7821 | (_1 (push-level)) | |
7822 | (_2 (for-each f1 b)) | |
7823 | (tb (maplr f2 b)) | |
7824 | (_3 (for-each limit-expansive tb)) | |
7825 | (ts-list (close (maplr f3 tb)))) | |
7826 | (pop-level) | |
7827 | (for-each2 f4 tb ts-list) | |
7828 | tb) | |
7829 | (let* ((f1 (match-lambda | |
7830 | (($ bind b _) (set-name-ty! b (tvar))))) | |
7831 | (f2 (match-lambda | |
7832 | (($ bind b e) | |
7833 | (make-bind b (w e component))))) | |
7834 | (f3 (match-lambda | |
7835 | (($ bind b e) | |
7836 | (unify (name-ty b) (typeof e))))) | |
7837 | (_1 (for-each f1 b)) | |
7838 | (tb (maplr f2 b))) | |
7839 | (for-each f3 tb) | |
7840 | tb)))) | |
7841 | (comps (make-letrec-components b)) | |
7842 | (tb (foldr append '() (maplr do-comp comps)))) | |
7843 | (make-letr tb (w e2 component)))) | |
7844 | (($ body defs exps) | |
7845 | (for-each | |
7846 | (match-lambda | |
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))) | |
7853 | (($ and exps) | |
7854 | (let* ((texps (maplr (lambda (x) (w x component)) exps)) | |
7855 | (t (match texps | |
7856 | (() (r+ initial-type-env 'true)) | |
7857 | ((e) (typeof e)) | |
7858 | (_ (let ((a (r+ initial-type-env 'false))) | |
7859 | (unify (typeof (rac texps)) a) | |
7860 | a))))) | |
7861 | (make-type t (make-and texps)))) | |
7862 | (($ or exps) | |
7863 | (let* ((texps (maplr (lambda (x) (w x component)) exps)) | |
7864 | (t (match texps | |
7865 | (() (r+ initial-type-env 'false)) | |
7866 | ((e) (typeof e)) | |
7867 | (_ (let* ((t-last (typeof (rac texps))) | |
7868 | (but-last (rdc texps)) | |
7869 | (a (tvar))) | |
7870 | (for-each | |
7871 | (lambda (e) | |
7872 | (unify (typeof e) | |
7873 | (r+ initial-type-env | |
7874 | `(+ (not false) ,a)))) | |
7875 | but-last) | |
7876 | (unify t-last | |
7877 | (r+ initial-type-env | |
7878 | `(+ (not false) ,a))) | |
7879 | t-last))))) | |
7880 | (make-type t (make-or texps)))) | |
7881 | (($ begin exps) | |
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)) | |
7888 | (a (tvar))) | |
7889 | (unify (typeof tthen) a) | |
7890 | (unify (typeof tels) a) | |
7891 | (make-type a (make-if ttest tthen tels)))) | |
7892 | (($ delay e2) | |
7893 | (let ((texp (w e2 component))) | |
7894 | (make-type | |
7895 | (r+ initial-type-env `(promise ,(typeof texp))) | |
7896 | (make-delay texp)))) | |
7897 | (($ set! x body) | |
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)) | |
7902 | (name-ty x)))) | |
7903 | (unify t (typeof body)) | |
7904 | (make-type | |
7905 | (r+ initial-type-env 'void) | |
7906 | (make-set! x body)))) | |
7907 | (($ record bind) | |
7908 | (let* ((tbind (map (match-lambda | |
7909 | (($ bind name exp) | |
7910 | (make-bind name (w exp component)))) | |
7911 | bind)) | |
7912 | (t (r+ initial-type-env | |
7913 | `(record | |
7914 | ,@(map (match-lambda | |
7915 | (($ bind name exp) | |
7916 | (list name (typeof exp)))) | |
7917 | tbind))))) | |
7918 | (make-type t (make-record tbind)))) | |
7919 | (($ field name exp) | |
7920 | (match-let* | |
7921 | ((texp (w exp component)) | |
7922 | (a (tvar)) | |
7923 | ((t absv) | |
7924 | (r-collect initial-type-env `(record (,name ,a))))) | |
7925 | (unify (typeof texp) t) | |
7926 | (make-type | |
7927 | a | |
7928 | (make-check | |
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)) | |
7934 | t) | |
7935 | (make-type | |
7936 | a | |
7937 | (make-check | |
7938 | (list absv #f #f #f component) | |
7939 | (make-cast (list ty t absv) texp))))) | |
7940 | (($ match exp clauses) | |
7941 | (for-each | |
7942 | (match-lambda | |
7943 | (($ mclause p _ (? name? fail)) | |
7944 | (set-name-ty! | |
7945 | fail | |
7946 | (r+ initial-type-env '(a ?-> b)))) | |
7947 | (_ #f)) | |
7948 | clauses) | |
7949 | (match-let* | |
7950 | ((iclauses | |
7951 | (improve-clauses | |
7952 | (append | |
7953 | clauses | |
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)) | |
7959 | (tclauses | |
7960 | (maplr (match-lambda | |
7961 | (($ mclause p e fail) | |
7962 | (make-mclause p (w e component) fail))) | |
7963 | clauses)) | |
7964 | (a (tvar))) | |
7965 | (for-each | |
7966 | (match-lambda | |
7967 | (($ mclause _ e _) (unify (typeof e) a))) | |
7968 | tclauses) | |
7969 | (make-type | |
7970 | a | |
7971 | (make-check | |
7972 | (list absv #f (not precise) #f component) | |
7973 | (make-match texp tclauses)))))))) | |
7974 | (define w-match | |
7975 | (lambda (clauses last) | |
7976 | (letrec ((bindings '()) | |
7977 | (encode | |
7978 | (match-lambda | |
7979 | (($ pand pats) (encode* pats)) | |
7980 | (x (encode* (list x))))) | |
7981 | (encode* | |
7982 | (lambda (pats) | |
7983 | (let* ((concrete? | |
7984 | (lambda (p) | |
7985 | (or (pconst? p) (pobj? p) (ppred? p) (pelse? p)))) | |
7986 | (var? (lambda (p) (or (pvar? p) (pany? p)))) | |
7987 | (not-var? | |
7988 | (lambda (p) | |
7989 | (and (not (pvar? p)) (not (pany? p))))) | |
7990 | (t (match (filter concrete? pats) | |
7991 | ((p) | |
7992 | (r+ initial-type-env | |
7993 | (match (template p) | |
7994 | ((x) x) | |
7995 | (x `(+ ,@x))))) | |
7996 | (() | |
7997 | (r+ initial-type-env | |
7998 | `(+ ,@(apply append | |
7999 | (map template | |
8000 | (filter | |
8001 | not-var? | |
8002 | pats))) | |
8003 | ,@(if (null? (filter var? pats)) | |
8004 | '() | |
8005 | (list (out1tvar))))))))) | |
8006 | (for-each | |
8007 | (match-lambda | |
8008 | (($ pvar b) | |
8009 | (set! bindings (cons b bindings)) | |
8010 | (set-name-ty! b (pat-var-bind t)))) | |
8011 | (filter pvar? pats)) | |
8012 | t))) | |
8013 | (template | |
8014 | (match-lambda | |
8015 | ((? pelse?) '()) | |
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))) | |
8022 | ((first . rest) | |
8023 | (list (foldr (lambda (x y) | |
8024 | (unify x y) | |
8025 | y) | |
8026 | first | |
8027 | rest)))))) | |
8028 | (else | |
8029 | (cons (car (name-predicate c)) | |
8030 | (maplr encode args)))))) | |
8031 | (($ ppred pred) | |
8032 | (cond ((eq? pred %boolean?) (list 'true 'false)) | |
8033 | ((eq? pred %list?) (list `(list ,(out1tvar)))) | |
8034 | (else | |
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)))) | |
8046 | (case m | |
8047 | ((0) `((not ,(car (name-predicate pred))))) | |
8048 | ((1) | |
8049 | `((,(car (name-predicate pred)) | |
8050 | ,@(map (match-lambda | |
8051 | (($ pobj pred _) | |
8052 | `(+ (not ,(car (name-predicate pred))) | |
8053 | ,(out1tvar))) | |
8054 | (($ ppred pred) | |
8055 | `(+ (not ,(car (name-predicate pred))) | |
8056 | ,(out1tvar))) | |
8057 | (_ (out1tvar))) | |
8058 | pats)))) | |
8059 | (else '())))))) | |
8060 | (non-triv | |
8061 | (match-lambda | |
8062 | ((? pvar?) 0) | |
8063 | ((? pany?) 0) | |
8064 | ((? pelse?) 0) | |
8065 | ((? pconst?) 2) | |
8066 | (($ pobj _ pats) (foldr + 1 (map non-triv pats))) | |
8067 | (_ 1))) | |
8068 | (precise | |
8069 | (match-lambda | |
8070 | ((? pconst?) #f) | |
8071 | (($ pand pats) (andmap precise pats)) | |
8072 | (($ pnot pat) (precise pat)) | |
8073 | (($ pobj pred pats) | |
8074 | (let ((m (foldr + 0 (map non-triv pats)))) | |
8075 | (case m | |
8076 | ((0) #t) | |
8077 | ((1) (andmap precise pats)) | |
8078 | (else #f)))) | |
8079 | (($ ppred pred) (not (eq? pred %list?))) | |
8080 | (_ #t)))) | |
8081 | (push-level) | |
8082 | (match-let* | |
8083 | ((precise-match | |
8084 | (and (andmap | |
8085 | (match-lambda (($ mclause _ _ fail) (not fail))) | |
8086 | clauses) | |
8087 | (match last (($ mclause p _ _) (precise p))))) | |
8088 | (types (maplr (match-lambda (($ mclause p _ _) (encode p))) | |
8089 | clauses)) | |
8090 | ((t absv) | |
8091 | (r-match | |
8092 | (foldr (lambda (x y) (unify x y) y) (tvar) types)))) | |
8093 | (unify (out1tvar) t) | |
8094 | (for-each limit-name bindings) | |
8095 | (for-each2 | |
8096 | set-name-ty! | |
8097 | bindings | |
8098 | (close (map name-ty bindings))) | |
8099 | (pop-level) | |
8100 | '(pretty-print | |
8101 | `(match-input | |
8102 | ,@(map (match-lambda (($ mclause p _ _) (ppat p))) | |
8103 | clauses))) | |
8104 | '(pretty-print | |
8105 | `(match-type | |
8106 | ,(ptype t) | |
8107 | ,@(map (lambda (b) (list (pname b) (ptype (name-ty b)))) | |
8108 | bindings))) | |
8109 | (list t absv precise-match))))) | |
8110 | (define syntactically-a-procedure? | |
8111 | (match-lambda | |
8112 | (($ type _ e) (syntactically-a-procedure? e)) | |
8113 | (($ check _ e) (syntactically-a-procedure? e)) | |
8114 | (($ var x) (name-primitive x)) | |
8115 | ((? lam?) #t) | |
8116 | ((? vlam?) #t) | |
8117 | (($ let _ body) | |
8118 | (syntactically-a-procedure? body)) | |
8119 | (($ let* _ body) | |
8120 | (syntactically-a-procedure? body)) | |
8121 | (($ letr _ body) | |
8122 | (syntactically-a-procedure? body)) | |
8123 | (($ if _ e2 e3) | |
8124 | (and (syntactically-a-procedure? e2) | |
8125 | (syntactically-a-procedure? e3))) | |
8126 | (($ begin exps) | |
8127 | (syntactically-a-procedure? (rac exps))) | |
8128 | (($ body _ exps) | |
8129 | (syntactically-a-procedure? (rac exps))) | |
8130 | (_ #f))) | |
8131 | (define typeof | |
8132 | (match-lambda | |
8133 | (($ type t _) t) | |
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)))) | |
8141 | (define limit-name | |
8142 | (lambda (n) | |
8143 | (when (name-mutated n) | |
8144 | (unify (name-ty n) (out1tvar))))) | |
8145 | (define limit-expansive | |
8146 | (letrec ((limit! (lambda (t) (unify t (out1tvar)))) | |
8147 | (expansive-pattern? | |
8148 | (match-lambda | |
8149 | ((? pconst?) #f) | |
8150 | (($ pvar x) (name-mutated x)) | |
8151 | (($ pobj _ pats) (ormap expansive-pattern? pats)) | |
8152 | ((? pany?) #f) | |
8153 | ((? pelse?) #f) | |
8154 | (($ pand pats) (ormap expansive-pattern? pats)) | |
8155 | (($ ppred x) (name-mutated x)) | |
8156 | (($ pnot pat) (expansive-pattern? pat)))) | |
8157 | (limit-expr | |
8158 | (match-lambda | |
8159 | (($ bind b e) | |
8160 | (if (name-mutated b) | |
8161 | (limit! (typeof e)) | |
8162 | (limit-expr e))) | |
8163 | ((? defstruct?) #f) | |
8164 | ((? datatype?) #f) | |
8165 | (($ define x e) | |
8166 | (if (and x (name-mutated x)) | |
8167 | (limit! (typeof e)) | |
8168 | (limit-expr e))) | |
8169 | (($ type | |
8170 | t | |
8171 | ($ app ($ type _ ($ check _ ($ var x))) exps)) | |
8172 | (cond ((list? (name-pure x)) | |
8173 | (if (= (length (name-pure x)) (length exps)) | |
8174 | (for-each2 | |
8175 | (lambda (pure e) | |
8176 | (if pure (limit-expr e) (limit! (typeof e)))) | |
8177 | (name-pure x) | |
8178 | exps) | |
8179 | (limit! t))) | |
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)) | |
8184 | (else (limit! t)))) | |
8185 | (($ type t ($ app _ _)) (limit! t)) | |
8186 | (($ type t ($ check _ ($ app _ _))) (limit! t)) | |
8187 | (($ delay _) #f) | |
8188 | (($ type t ($ set! _ _)) (limit! t)) | |
8189 | (($ var _) #f) | |
8190 | ((? const?) #f) | |
8191 | (($ lam _ _) #f) | |
8192 | (($ vlam _ _ _) #f) | |
8193 | (($ let bind body) | |
8194 | (limit-expr body) | |
8195 | (for-each limit-expr bind)) | |
8196 | (($ let* bind body) | |
8197 | (limit-expr body) | |
8198 | (for-each limit-expr bind)) | |
8199 | (($ letr bind body) | |
8200 | (limit-expr body) | |
8201 | (for-each limit-expr bind)) | |
8202 | (($ body defs exps) | |
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)) | |
8208 | (($ if e1 e2 e3) | |
8209 | (limit-expr e1) | |
8210 | (limit-expr e2) | |
8211 | (limit-expr e3)) | |
8212 | (($ record bind) | |
8213 | (for-each | |
8214 | (match-lambda (($ bind _ e) (limit-expr e))) | |
8215 | bind)) | |
8216 | (($ field _ exp) (limit-expr exp)) | |
8217 | (($ cast _ exp) (limit-expr exp)) | |
8218 | (($ match exp clauses) | |
8219 | (limit-expr exp) | |
8220 | (for-each | |
8221 | (match-lambda | |
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)))) | |
8227 | clauses)) | |
8228 | (($ type _ e1) (limit-expr e1)) | |
8229 | (($ check _ e1) (limit-expr e1))))) | |
8230 | limit-expr)) | |
8231 | (define unparse | |
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)) | |
8240 | (($ define x e) | |
8241 | (if (or (not x) (and (name? x) (not (name-name x)))) | |
8242 | (pexpr e) | |
8243 | `(define ,(pname x) ,(pexpr e)))) | |
8244 | (($ defstruct _ args _ _ _ _ _ _ _) | |
8245 | `(check-define-const-structure ,args)) | |
8246 | (($ datatype d) | |
8247 | `(datatype | |
8248 | ,@(map (match-lambda | |
8249 | (((tag . args) . bindings) | |
8250 | (cons (cons (ptag tag) args) | |
8251 | (map (match-lambda | |
8252 | (($ variant _ _ types) types)) | |
8253 | bindings)))) | |
8254 | d))) | |
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)) | |
8261 | (($ lam x e1) | |
8262 | `(lambda ,(maplr pname x) ,@(pexpr e1))) | |
8263 | (($ vlam x rest e1) | |
8264 | `(lambda ,(append (maplr pname x) (pname rest)) | |
8265 | ,@(pexpr e1))) | |
8266 | (($ match e1 clauses) | |
8267 | (let* ((pclause | |
8268 | (match-lambda | |
8269 | (($ mclause p #f #f) | |
8270 | `(,(ppat p) <last clause>)) | |
8271 | (($ mclause p exp fail) | |
8272 | (if fail | |
8273 | `(,(ppat p) | |
8274 | (=> ,(pname fail)) | |
8275 | ,@(pexpr exp)) | |
8276 | `(,(ppat p) ,@(pexpr exp)))))) | |
8277 | (p1 (pexpr e1))) | |
8278 | `(match ,p1 ,@(maplr pclause clauses)))) | |
8279 | (($ app e1 args) | |
8280 | (let* ((p1 (pexpr e1)) | |
8281 | (pargs (maplr pexpr args)) | |
8282 | (unkwote | |
8283 | (match-lambda | |
8284 | (('quote x) x) | |
8285 | ((? boolean? x) x) | |
8286 | ((? number? x) x) | |
8287 | ((? char? x) x) | |
8288 | ((? string? x) x) | |
8289 | ((? null? x) x) | |
8290 | ((? box? x) x) | |
8291 | ((? vector? x) x)))) | |
8292 | (cond ((eq? p1 qlist) `',(maplr unkwote pargs)) | |
8293 | ((eq? p1 qcons) | |
8294 | (let ((unq (maplr unkwote pargs))) | |
8295 | `',(cons (car unq) (cadr unq)))) | |
8296 | ((eq? p1 qbox) (box (unkwote (car pargs)))) | |
8297 | ((eq? p1 qvector) | |
8298 | (list->vector (maplr unkwote pargs))) | |
8299 | (else (cons p1 pargs))))) | |
8300 | (($ let b e2) | |
8301 | (let ((pb (maplr pbind b))) | |
8302 | `(let ,pb ,@(pexpr e2)))) | |
8303 | (($ let* b e2) | |
8304 | (let ((pb (maplr pbind b))) | |
8305 | `(let* ,pb ,@(pexpr e2)))) | |
8306 | (($ letr b e2) | |
8307 | (let ((pb (maplr pbind b))) | |
8308 | `(letrec ,pb ,@(pexpr e2)))) | |
8309 | (($ body defs exps) | |
8310 | (let ((pdefs (maplr pexpr defs))) | |
8311 | (append pdefs (maplr pexpr exps)))) | |
8312 | (($ if e1 e2 e3) | |
8313 | (let* ((p1 (pexpr e1)) (p2 (pexpr e2)) (p3 (pexpr e3))) | |
8314 | `(if ,p1 ,p2 ,p3))) | |
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)))))) | |
8321 | (pexpr e)))) | |
8322 | (define pexpr | |
8323 | (lambda (ex) | |
8324 | (unparse | |
8325 | ex | |
8326 | (lambda (e pexpr) | |
8327 | (match e | |
8328 | (($ type _ ($ check _ exp)) (pexpr exp))))))) | |
8329 | (define pdef pexpr) | |
8330 | (define ppat | |
8331 | (match-lambda | |
8332 | (($ pconst x _) (pconst x)) | |
8333 | (($ pvar x) (pname x)) | |
8334 | (($ pany) '_) | |
8335 | (($ pelse) 'else) | |
8336 | (($ pnot pat) `(not ,(ppat pat))) | |
8337 | (($ pand pats) `(and ,@(maplr ppat pats))) | |
8338 | (($ ppred pred) | |
8339 | (match (pname pred) | |
8340 | ('false-object? #f) | |
8341 | ('true-object? #t) | |
8342 | ('null? '()) | |
8343 | (x `(? ,x)))) | |
8344 | (($ pobj tag args) | |
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))))))) | |
8350 | (define strip-? | |
8351 | (lambda (s) | |
8352 | (let* ((str (symbol->string s)) | |
8353 | (n (string-length str))) | |
8354 | (if (or (zero? n) | |
8355 | (not (char=? #\? (string-ref str (- n 1))))) | |
8356 | s | |
8357 | (string->symbol (substring str 0 (- n 1))))))) | |
8358 | (define pname | |
8359 | (match-lambda | |
8360 | ((? name? x) (or (name-name x) '<expr>)) | |
8361 | ((? symbol? x) x))) | |
8362 | (define ptag | |
8363 | (match-lambda | |
8364 | ((? k? k) (k-name k)) | |
8365 | ((? symbol? x) x))) | |
8366 | (define pconst | |
8367 | (match-lambda | |
8368 | ((? symbol? x) `',x) | |
8369 | ((? boolean? x) x) | |
8370 | ((? number? x) x) | |
8371 | ((? char? x) x) | |
8372 | ((? string? x) x) | |
8373 | ((? null? x) `',x))) | |
8374 | (define check | |
8375 | (lambda (file) | |
8376 | (output-checked file '() type-check?))) | |
8377 | (define profcheck | |
8378 | (lambda (file) | |
8379 | (output-checked #f '() type-check?) | |
8380 | (output-checked | |
8381 | #f | |
8382 | (make-counters total-possible) | |
8383 | type-check?))) | |
8384 | (define fullcheck | |
8385 | (lambda (file) | |
8386 | (let ((check? (lambda (_) #t))) | |
8387 | (output-checked #f '() check?) | |
8388 | (output-checked | |
8389 | #f | |
8390 | (make-counters total-possible) | |
8391 | check?)))) | |
8392 | (define make-counters | |
8393 | (lambda (n) | |
8394 | (let* ((init `(define check-counters (make-vector ,n 0))) | |
8395 | (sum '(define check-total | |
8396 | (lambda () | |
8397 | (let ((foldr (lambda (f i l) | |
8398 | (recur loop | |
8399 | ((l l)) | |
8400 | (match l | |
8401 | (() i) | |
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) | |
8407 | (vector-set! | |
8408 | check-counters | |
8409 | c | |
8410 | (+ 1 (vector-ref check-counters c))))))) | |
8411 | (list init sum incr)))) | |
8412 | (define output-checked | |
8413 | (lambda (file header check-test) | |
8414 | (set! summary '()) | |
8415 | (set! total-possible 0) | |
8416 | (set! total-cast 0) | |
8417 | (set! total-err 0) | |
8418 | (set! total-any 0) | |
8419 | (let ((doit (lambda () | |
8420 | (when (string? file) | |
8421 | (printf | |
8422 | ";; Generated by Soft Scheme ~a~%" | |
8423 | st:version) | |
8424 | (printf ";; (st:control") | |
8425 | (for-each | |
8426 | (lambda (x) (printf " '~a" x)) | |
8427 | (show-controls)) | |
8428 | (printf ")~%") | |
8429 | (unless | |
8430 | (= 0 n-unbound) | |
8431 | (printf | |
8432 | ";; CAUTION: ~a unbound references, this code is not safe~%" | |
8433 | n-unbound)) | |
8434 | (printf "~%") | |
8435 | (for-each pretty-print header)) | |
8436 | (for-each | |
8437 | (lambda (exp) | |
8438 | (match exp | |
8439 | (($ define x _) | |
8440 | (set! n-possible 0) | |
8441 | (set! n-clash 0) | |
8442 | (set! n-err 0) | |
8443 | (set! n-match 0) | |
8444 | (set! n-inexhaust 0) | |
8445 | (set! n-prim 0) | |
8446 | (set! n-lam 0) | |
8447 | (set! n-app 0) | |
8448 | (set! n-field 0) | |
8449 | (set! n-cast 0) | |
8450 | (if file | |
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)) | |
8458 | (set! total-any | |
8459 | (+ total-any | |
8460 | n-match | |
8461 | n-inexhaust | |
8462 | n-prim | |
8463 | n-lam | |
8464 | n-app | |
8465 | n-field | |
8466 | n-cast))) | |
8467 | (_ (when file | |
8468 | (pretty-print | |
8469 | (pcheck exp check-test)))))) | |
8470 | tree) | |
8471 | (when (string? file) | |
8472 | (newline) | |
8473 | (newline) | |
8474 | (print-summary "; "))))) | |
8475 | (if (string? file) | |
8476 | (begin | |
8477 | (delete-file file) | |
8478 | (with-output-to-file file doit)) | |
8479 | (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) | |
8485 | (define n-clash 0) | |
8486 | (define n-err 0) | |
8487 | (define n-match 0) | |
8488 | (define n-inexhaust 0) | |
8489 | (define n-prim 0) | |
8490 | (define n-lam 0) | |
8491 | (define n-app 0) | |
8492 | (define n-field 0) | |
8493 | (define n-cast 0) | |
8494 | (define summary '()) | |
8495 | (define make-summary-line | |
8496 | (lambda (x) | |
8497 | (let ((total (+ n-match | |
8498 | n-inexhaust | |
8499 | n-prim | |
8500 | n-lam | |
8501 | n-app | |
8502 | n-field | |
8503 | n-cast))) | |
8504 | (unless | |
8505 | (= 0 total) | |
8506 | (let* ((s (sprintf | |
8507 | "~a~a " | |
8508 | (padr (pname x) 16) | |
8509 | (padl total 2))) | |
8510 | (s (cond ((< 0 n-inexhaust) | |
8511 | (sprintf | |
8512 | "~a (~a match ~a inexhaust)" | |
8513 | s | |
8514 | n-match | |
8515 | n-inexhaust)) | |
8516 | ((< 0 n-match) | |
8517 | (sprintf "~a (~a match)" s n-match)) | |
8518 | (else s))) | |
8519 | (s (if (< 0 n-prim) | |
8520 | (sprintf "~a (~a prim)" s n-prim) | |
8521 | s)) | |
8522 | (s (if (< 0 n-field) | |
8523 | (sprintf "~a (~a field)" s n-field) | |
8524 | s)) | |
8525 | (s (if (< 0 n-lam) | |
8526 | (sprintf "~a (~a lambda)" s n-lam) | |
8527 | s)) | |
8528 | (s (if (< 0 n-app) (sprintf "~a (~a ap)" s n-app) s)) | |
8529 | (s (if (< 0 n-err) | |
8530 | (sprintf "~a (~a ERROR)" s n-err) | |
8531 | s)) | |
8532 | (s (if (< 0 n-cast) | |
8533 | (sprintf "~a (~a TYPE)" s n-cast) | |
8534 | s))) | |
8535 | (set! summary (cons s summary))))))) | |
8536 | (define print-summary | |
8537 | (lambda (hdr) | |
8538 | (for-each | |
8539 | (lambda (s) (printf "~a~a~%" hdr s)) | |
8540 | (reverse summary)) | |
8541 | (printf | |
8542 | "~a~a~a " | |
8543 | hdr | |
8544 | (padr "TOTAL CHECKS" 16) | |
8545 | (padl total-any 2)) | |
8546 | (printf | |
8547 | " (of ~s is ~s%)" | |
8548 | total-possible | |
8549 | (if (= 0 total-possible) | |
8550 | 0 | |
8551 | (string->number | |
8552 | (chop-number | |
8553 | (exact->inexact | |
8554 | (* (/ total-any total-possible) 100)) | |
8555 | 4)))) | |
8556 | (when (< 0 total-err) | |
8557 | (printf " (~s ERROR)" total-err)) | |
8558 | (when (< 0 total-cast) | |
8559 | (printf " (~s TYPE)" total-cast)) | |
8560 | (printf "~%"))) | |
8561 | (define padl | |
8562 | (lambda (arg n) | |
8563 | (let ((s (sprintf "~a" arg))) | |
8564 | (recur loop | |
8565 | ((s s)) | |
8566 | (if (< (string-length s) n) | |
8567 | (loop (string-append " " s)) | |
8568 | s))))) | |
8569 | (define padr | |
8570 | (lambda (arg n) | |
8571 | (let ((s (sprintf "~a" arg))) | |
8572 | (recur loop | |
8573 | ((s s)) | |
8574 | (if (< (string-length s) n) | |
8575 | (loop (string-append s " ")) | |
8576 | s))))) | |
8577 | (define chop-number | |
8578 | (lambda (x n) | |
8579 | (substring | |
8580 | (sprintf "~s00000000000000000000" x) | |
8581 | 0 | |
8582 | (- n 1)))) | |
8583 | (define pcheck | |
8584 | (lambda (ex check-test) | |
8585 | (unparse | |
8586 | ex | |
8587 | (lambda (e pexpr) | |
8588 | (match e | |
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) | |
8593 | (#f (pname x)) | |
8594 | ('def | |
8595 | (set! n-err (+ 1 n-err)) | |
8596 | (set! n-prim (+ 1 n-prim)) | |
8597 | `(,(symbol-append "CHECK-" (pname x)) | |
8598 | ,(tree-index z) | |
8599 | ',(string->symbol "ERROR"))) | |
8600 | (_ (set! n-prim (+ 1 n-prim)) | |
8601 | `(,(symbol-append "CHECK-" (pname x)) | |
8602 | ,(tree-index z))))) | |
8603 | ((name-unbound? x) `(check-bound ,(pname x))) | |
8604 | (else | |
8605 | (if (check-test inf) | |
8606 | (begin | |
8607 | (set! n-clash (+ 1 n-clash)) | |
8608 | `(,(string->symbol "CLASH") | |
8609 | ,(pname x) | |
8610 | ,(tree-index z))) | |
8611 | (pname x))))) | |
8612 | ((and z | |
8613 | ($ type _ ($ check inf (and m ($ lam x e1))))) | |
8614 | (set! n-possible (+ 1 n-possible)) | |
8615 | (match (check-test inf) | |
8616 | (#f (pexpr m)) | |
8617 | ('def | |
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")) | |
8622 | ,(map pname x) | |
8623 | ,@(pexpr e1))) | |
8624 | (_ (set! n-lam (+ 1 n-lam)) | |
8625 | `(,(string->symbol "CHECK-lambda") | |
8626 | (,(tree-index z)) | |
8627 | ,(map pname x) | |
8628 | ,@(pexpr e1))))) | |
8629 | ((and z | |
8630 | ($ type | |
8631 | _ | |
8632 | ($ check inf (and m ($ vlam x rest e1))))) | |
8633 | (set! n-possible (+ 1 n-possible)) | |
8634 | (match (check-test inf) | |
8635 | (#f (pexpr m)) | |
8636 | ('def | |
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)) | |
8642 | ,@(pexpr e1))) | |
8643 | (_ (set! n-lam (+ 1 n-lam)) | |
8644 | `(,(string->symbol "CHECK-lambda") | |
8645 | (,(tree-index z)) | |
8646 | ,(append (map pname x) (pname rest)) | |
8647 | ,@(pexpr e1))))) | |
8648 | ((and z | |
8649 | ($ type _ ($ check inf (and m ($ app e1 args))))) | |
8650 | (set! n-possible (+ 1 n-possible)) | |
8651 | (match (check-test inf) | |
8652 | (#f (pexpr m)) | |
8653 | ('def | |
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")) | |
8658 | ,(pexpr e1) | |
8659 | ,@(map pexpr args))) | |
8660 | (_ (set! n-app (+ 1 n-app)) | |
8661 | (let ((p1 (pexpr e1))) | |
8662 | `(,(string->symbol "CHECK-ap") | |
8663 | (,(tree-index z)) | |
8664 | ,p1 | |
8665 | ,@(map pexpr args)))))) | |
8666 | ((and z | |
8667 | ($ type _ ($ check inf (and m ($ field x e1))))) | |
8668 | (set! n-possible (+ 1 n-possible)) | |
8669 | (match (check-test inf) | |
8670 | (#f (pexpr m)) | |
8671 | ('def | |
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")) | |
8676 | ,x | |
8677 | ,(pexpr e1))) | |
8678 | (_ (set! n-field (+ 1 n-field)) | |
8679 | `(,(string->symbol "CHECK-field") | |
8680 | (,(tree-index z)) | |
8681 | ,x | |
8682 | ,(pexpr e1))))) | |
8683 | ((and z | |
8684 | ($ type | |
8685 | _ | |
8686 | ($ check inf (and m ($ cast (x . _) e1))))) | |
8687 | (set! n-possible (+ 1 n-possible)) | |
8688 | (match (check-test inf) | |
8689 | (#f (pexpr m)) | |
8690 | (_ (set! n-cast (+ 1 n-cast)) | |
8691 | `(,(string->symbol "CHECK-:") | |
8692 | (,(tree-index z)) | |
8693 | ,x | |
8694 | ,(pexpr e1))))) | |
8695 | ((and z | |
8696 | ($ type | |
8697 | _ | |
8698 | ($ check inf (and m ($ match e1 clauses))))) | |
8699 | (set! n-possible (+ 1 n-possible)) | |
8700 | (match (check-test inf) | |
8701 | (#f (pexpr m)) | |
8702 | (inx (let* ((pclause | |
8703 | (match-lambda | |
8704 | (($ mclause p exp fail) | |
8705 | (if fail | |
8706 | `(,(ppat p) | |
8707 | (=> ,(pname fail)) | |
8708 | ,@(pexpr exp)) | |
8709 | `(,(ppat p) ,@(pexpr exp)))))) | |
8710 | (p1 (pexpr e1))) | |
8711 | (if (eq? 'inexhaust inx) | |
8712 | (begin | |
8713 | (set! n-inexhaust (+ 1 n-inexhaust)) | |
8714 | `(,(string->symbol "CHECK-match") | |
8715 | (,(tree-index z) | |
8716 | ,(string->symbol "INEXHAUST")) | |
8717 | ,p1 | |
8718 | ,@(maplr pclause clauses))) | |
8719 | (begin | |
8720 | (set! n-match (+ 1 n-match)) | |
8721 | `(,(string->symbol "CHECK-match") | |
8722 | (,(tree-index z)) | |
8723 | ,p1 | |
8724 | ,@(maplr pclause clauses))))))))))))) | |
8725 | (define tree-index-list '()) | |
8726 | (define reinit-output! | |
8727 | (lambda () (set! tree-index-list '()))) | |
8728 | (define tree-index | |
8729 | (lambda (syntax) | |
8730 | (match (assq syntax tree-index-list) | |
8731 | (#f | |
8732 | (let ((n (length tree-index-list))) | |
8733 | (set! tree-index-list | |
8734 | (cons (cons syntax n) tree-index-list)) | |
8735 | n)) | |
8736 | ((_ . n) n)))) | |
8737 | (define tree-unindex | |
8738 | (lambda (n) | |
8739 | (let ((max (length tree-index-list))) | |
8740 | (when (<= max n) | |
8741 | (use-error "Invalid CHECK number ~a" n)) | |
8742 | (car (list-ref tree-index-list (- (- max 1) n)))))) | |
8743 | (define cause | |
8744 | (lambda () | |
8745 | (for-each | |
8746 | (lambda (def) | |
8747 | (for-each pretty-print (exp-cause def))) | |
8748 | tree))) | |
8749 | (define cause* | |
8750 | (lambda names | |
8751 | (if (null? names) | |
8752 | (for-each | |
8753 | (lambda (def) | |
8754 | (for-each pretty-print (exp-cause def))) | |
8755 | tree) | |
8756 | (for-each | |
8757 | (match-lambda | |
8758 | ((? symbol? dname) | |
8759 | (for-each | |
8760 | pretty-print | |
8761 | (exp-cause (find-global dname))))) | |
8762 | names)))) | |
8763 | (define exp-cause | |
8764 | (let ((sum (lambda (exps) | |
8765 | (foldr (lambda (x y) (append (exp-cause x) y)) | |
8766 | '() | |
8767 | exps))) | |
8768 | (src (lambda (inf) | |
8769 | (let ((nonlocal (map tree-index (check-sources inf)))) | |
8770 | (if (type-check1? inf) | |
8771 | (cons (check-local-sources inf) nonlocal) | |
8772 | nonlocal))))) | |
8773 | (match-lambda | |
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)) | |
8778 | ,(tree-index z)) | |
8779 | ,@(src inf))) | |
8780 | '()) | |
8781 | (if (type-check1? inf) | |
8782 | (list `((clash ,(pname x) ,(tree-index z)) ,@(src inf))) | |
8783 | '()))) | |
8784 | ((and z ($ type ty ($ check inf ($ lam x e1)))) | |
8785 | (append | |
8786 | (if (type-check? inf) | |
8787 | (list `((check-lambda ,(tree-index z) ,(map pname x) ...) | |
8788 | ,@(src inf))) | |
8789 | '()) | |
8790 | (exp-cause e1))) | |
8791 | ((and z | |
8792 | ($ type ty ($ check inf ($ vlam x rest e1)))) | |
8793 | (append | |
8794 | (if (type-check? inf) | |
8795 | (list `((check-lambda | |
8796 | ,(tree-index z) | |
8797 | ,(append (map pname x) (pname rest)) | |
8798 | ...) | |
8799 | ,@(src inf))) | |
8800 | '()) | |
8801 | (exp-cause e1))) | |
8802 | ((and z ($ type _ ($ check inf ($ app e1 args)))) | |
8803 | (append | |
8804 | (if (type-check? inf) | |
8805 | (list `((check-ap ,(tree-index z)) ,@(src inf))) | |
8806 | '()) | |
8807 | (exp-cause e1) | |
8808 | (sum args))) | |
8809 | ((and z ($ type _ ($ check inf ($ field x e1)))) | |
8810 | (append | |
8811 | (if (type-check? inf) | |
8812 | (list `((check-field ,(tree-index z) ,x ...) | |
8813 | ,@(src inf))) | |
8814 | '()) | |
8815 | (exp-cause e1))) | |
8816 | ((and z | |
8817 | ($ type _ ($ check inf ($ cast (x . _) e1)))) | |
8818 | (append | |
8819 | (if (type-check? inf) | |
8820 | (list `((check-: ,(tree-index z) ,x ...) ,@(src inf))) | |
8821 | '()) | |
8822 | (exp-cause e1))) | |
8823 | ((and z | |
8824 | ($ type | |
8825 | _ | |
8826 | ($ check inf (and m ($ match e1 clauses))))) | |
8827 | (append | |
8828 | (if (type-check? inf) | |
8829 | (list `((check-match ,(tree-index z) ...) ,@(src inf))) | |
8830 | '()) | |
8831 | (exp-cause m))) | |
8832 | (($ define _ e) (exp-cause e)) | |
8833 | ((? defstruct?) '()) | |
8834 | ((? datatype?) '()) | |
8835 | (($ app e1 args) (sum (cons e1 args))) | |
8836 | (($ match exp clauses) | |
8837 | (foldr (lambda (x y) | |
8838 | (append | |
8839 | (match x (($ mclause _ e _) (exp-cause e))) | |
8840 | y)) | |
8841 | (exp-cause exp) | |
8842 | clauses)) | |
8843 | (($ var _) '()) | |
8844 | (($ and exps) (sum exps)) | |
8845 | (($ begin exps) (sum exps)) | |
8846 | ((? const?) '()) | |
8847 | (($ if test then els) | |
8848 | (append | |
8849 | (exp-cause test) | |
8850 | (exp-cause then) | |
8851 | (exp-cause els))) | |
8852 | (($ let bindings body) | |
8853 | (foldr (lambda (x y) | |
8854 | (append (match x (($ bind _ e) (exp-cause e))) y)) | |
8855 | (exp-cause body) | |
8856 | bindings)) | |
8857 | (($ let* bindings body) | |
8858 | (foldr (lambda (x y) | |
8859 | (append (match x (($ bind _ e) (exp-cause e))) y)) | |
8860 | (exp-cause body) | |
8861 | bindings)) | |
8862 | (($ letr bindings body) | |
8863 | (foldr (lambda (x y) | |
8864 | (append (match x (($ bind _ e) (exp-cause e))) y)) | |
8865 | (exp-cause body) | |
8866 | bindings)) | |
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)) | |
8874 | '() | |
8875 | bindings)) | |
8876 | (($ type _ exp) (exp-cause exp))))) | |
8877 | (define display-type tidy) | |
8878 | (define type | |
8879 | (lambda names | |
8880 | (if (null? names) | |
8881 | (for-each globaldef tree) | |
8882 | (for-each | |
8883 | (match-lambda | |
8884 | ((? symbol? x) | |
8885 | (match (lookup? global-env x) | |
8886 | (#f (use-error "~a is not defined" x)) | |
8887 | (ty (pretty-print | |
8888 | `(,x : ,(display-type (name-ty ty))))))) | |
8889 | ((? number? n) | |
8890 | (let* ((ty (check-type (tree-unindex n))) | |
8891 | (type (display-type ty))) | |
8892 | (pretty-print `(,n : ,type)))) | |
8893 | (_ (use-error | |
8894 | "arguments must be identifiers or CHECK numbers"))) | |
8895 | names)))) | |
8896 | (define localtype | |
8897 | (lambda names | |
8898 | (if (null? names) | |
8899 | (for-each localdef tree) | |
8900 | (for-each | |
8901 | (lambda (x) (localdef (find-global x))) | |
8902 | names)))) | |
8903 | (define find-global | |
8904 | (lambda (name) | |
8905 | (let ((d (ormap (match-lambda | |
8906 | ((and d ($ define x _)) | |
8907 | (and (eq? name (name-name x)) d)) | |
8908 | (_ #f)) | |
8909 | tree))) | |
8910 | (unless d (use-error "~a is not defined" name)) | |
8911 | d))) | |
8912 | (define globaldef | |
8913 | (lambda (e) | |
8914 | (match e | |
8915 | (($ define x _) | |
8916 | (let ((type (display-type (name-ty x)))) | |
8917 | (pretty-print `(,(pname x) : ,type)))) | |
8918 | (_ #f)))) | |
8919 | (define localdef | |
8920 | (lambda (e) (pretty-print (expdef e)))) | |
8921 | (define expdef | |
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)))))) | |
8926 | (match-lambda | |
8927 | (($ define x e) | |
8928 | (if (or (not x) (and (name? x) (not (name-name x)))) | |
8929 | (expdef e) | |
8930 | `(define ,(show x) ,(expdef e)))) | |
8931 | ((? defstruct? d) (pdef d)) | |
8932 | ((? datatype? d) (pdef d)) | |
8933 | (($ and exps) `(and ,@(maplr expdef exps))) | |
8934 | (($ app fun args) | |
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)) | |
8944 | ,@(expdef body))) | |
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))) | |
8951 | (($ body defs exps) | |
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))) | |
8960 | (($ set! x body) | |
8961 | `(set! ,(pname x) ,(expdef body))) | |
8962 | (($ var x) (pname x)) | |
8963 | (($ match e1 clauses) | |
8964 | (let* ((pclause | |
8965 | (match-lambda | |
8966 | (($ mclause p exp fail) | |
8967 | (if fail | |
8968 | `(,(expdef p) (=> ,(pname fail)) ,@(expdef exp)) | |
8969 | `(,(expdef p) ,@(expdef exp)))))) | |
8970 | (p1 (expdef e1))) | |
8971 | `(match ,p1 ,@(maplr pclause clauses)))) | |
8972 | (($ pconst x _) (pconst x)) | |
8973 | (($ pvar x) (show x)) | |
8974 | (($ pany) '_) | |
8975 | (($ pelse) 'else) | |
8976 | (($ pnot pat) `(not ,(expdef pat))) | |
8977 | (($ pand pats) `(and ,@(maplr expdef pats))) | |
8978 | (($ ppred pred) | |
8979 | (match (pname pred) | |
8980 | ('false-object? #f) | |
8981 | ('true-object? #t) | |
8982 | ('null? '()) | |
8983 | (x `(? ,x)))) | |
8984 | (($ pobj tag args) | |
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))) | |
8989 | ((tg . _) | |
8990 | `($ ,(strip-? tg) ,@(maplr expdef args))))) | |
8991 | (($ type _ exp) (expdef exp)) | |
8992 | (($ check _ exp) (expdef exp))))) | |
8993 | (define check-type | |
8994 | (match-lambda | |
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))) | |
8999 | (typeof e1)) | |
9000 | (($ type _ ($ check inf ($ field x e1))) | |
9001 | (typeof e1)) | |
9002 | (($ type _ ($ check inf ($ cast (x . _) e1))) | |
9003 | (typeof e1)) | |
9004 | (($ type _ ($ check inf ($ match e1 clauses))) | |
9005 | (typeof e1)))) | |
9006 | (define tree '()) | |
9007 | (define global-env empty-env) | |
9008 | (define verbose #f) | |
9009 | (define times #t) | |
9010 | (define benchmarking #f) | |
9011 | (define cons-mutators '(set-car! set-cdr!)) | |
9012 | (define st:check | |
9013 | (lambda args | |
9014 | (parameterize | |
9015 | ((print-level #f) | |
9016 | (print-length #f) | |
9017 | (pretty-maximum-lines #f)) | |
9018 | (let ((output (apply do-soft args))) | |
9019 | (when output | |
9020 | (printf | |
9021 | "Typed program written to file ~a~%" | |
9022 | output)))))) | |
9023 | (define st:run | |
9024 | (lambda (file) | |
9025 | (parameterize | |
9026 | ((optimize-level 3)) | |
9027 | (when benchmarking | |
9028 | (printf "Reloading slow CHECKs...~%") | |
9029 | (load (string-append | |
9030 | installation-directory | |
9031 | "checklib.scm")) | |
9032 | (set! benchmarking #f)) | |
9033 | (load file)))) | |
9034 | (define st:bench | |
9035 | (lambda (file) | |
9036 | (parameterize | |
9037 | ((optimize-level 3)) | |
9038 | (unless | |
9039 | benchmarking | |
9040 | (unless | |
9041 | fastlibrary-file | |
9042 | (use-error | |
9043 | "No benchmarking mode in this version")) | |
9044 | (printf "Reloading fast CHECKs...~%") | |
9045 | (load (string-append | |
9046 | installation-directory | |
9047 | fastlibrary-file)) | |
9048 | (set! benchmarking #t)) | |
9049 | (load file)))) | |
9050 | (define st: | |
9051 | (lambda args | |
9052 | (parameterize | |
9053 | ((print-level #f) | |
9054 | (print-length #f) | |
9055 | (pretty-maximum-lines #f)) | |
9056 | (let ((output (apply do-soft args))) | |
9057 | (cond ((not output) | |
9058 | (use-error "Output file name required to run")) | |
9059 | ((= 0 n-unbound) | |
9060 | (printf | |
9061 | "Typed program written to file ~a, executing ...~%" | |
9062 | output) | |
9063 | (flush-output) | |
9064 | (st:run output)) | |
9065 | (else | |
9066 | (printf | |
9067 | "Typed program written to file ~a, not executing (unbound refs)~%" | |
9068 | output))))))) | |
9069 | (define do-soft | |
9070 | (match-lambda* | |
9071 | ((input (? string? output)) | |
9072 | (when (strip-suffix output) | |
9073 | (use-error | |
9074 | "output file name cannot end in .ss or .scm")) | |
9075 | (cond ((string? input) | |
9076 | (soft-files (list input) output) | |
9077 | output) | |
9078 | ((and (list? input) (andmap string? input)) | |
9079 | (soft-files input output) | |
9080 | output) | |
9081 | (else (soft-def input output) output))) | |
9082 | ((input #f) | |
9083 | (cond ((string? input) (soft-files (list input) #f) #f) | |
9084 | ((and (list? input) (andmap string? input)) | |
9085 | (soft-files input #f) | |
9086 | #f) | |
9087 | (else (soft-def input #f) #f))) | |
9088 | ((input) | |
9089 | (cond ((string? input) | |
9090 | (let ((o (string-append | |
9091 | (or (strip-suffix input) input) | |
9092 | ".soft"))) | |
9093 | (soft-files (list input) o) | |
9094 | o)) | |
9095 | ((and (list? input) (andmap string? input)) | |
9096 | (use-error "Output file name required")) | |
9097 | (else (soft-def input #t) #f))) | |
9098 | (else (use-error | |
9099 | "Input must be a file name or list of file names")))) | |
9100 | (define rawmode #f) | |
9101 | (define st:control | |
9102 | (lambda args | |
9103 | (let ((dbg (match-lambda | |
9104 | ('raw | |
9105 | (set! display-type ptype) | |
9106 | (set! rawmode #t)) | |
9107 | ('!raw | |
9108 | (set! display-type tidy) | |
9109 | (set! rawmode #f)) | |
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) | |
9137 | (st:control))))) | |
9138 | (if (null? args) | |
9139 | (begin | |
9140 | (printf "Current values:") | |
9141 | (for-each | |
9142 | (lambda (x) (printf " ~a" x)) | |
9143 | (show-controls)) | |
9144 | (printf "~%")) | |
9145 | (for-each dbg args))))) | |
9146 | (define show-controls | |
9147 | (lambda () | |
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)))) | |
9162 | (define soft-def | |
9163 | (lambda (exp output) | |
9164 | (reinit-macros!) | |
9165 | (reinit-types!) | |
9166 | (reinit-output!) | |
9167 | (set! visible-time 0) | |
9168 | (match-let* | |
9169 | ((before-parse (cpu-time)) | |
9170 | (defs (parse-def exp)) | |
9171 | (before-bind (cpu-time)) | |
9172 | ((defs env tenv unbound) | |
9173 | (bind-defs | |
9174 | defs | |
9175 | initial-env | |
9176 | initial-type-env | |
9177 | '() | |
9178 | 0)) | |
9179 | (_ (warn-unbound unbound)) | |
9180 | (_ (if cons-is-mutable | |
9181 | (printf | |
9182 | "Note: use of ~a, treating cons as MUTABLE~%" | |
9183 | cons-mutators) | |
9184 | (printf | |
9185 | "Note: no use of ~a, treating cons as immutable~%" | |
9186 | cons-mutators))) | |
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)) | |
9193 | (_ (check output)) | |
9194 | (_ (print-summary "")) | |
9195 | (before-end (cpu-time))) | |
9196 | (when times | |
9197 | (printf | |
9198 | "~a seconds parsing,~%" | |
9199 | (exact->inexact | |
9200 | (* (- before-bind before-parse) | |
9201 | clock-granularity))) | |
9202 | (printf | |
9203 | "~a seconds binding,~%" | |
9204 | (exact->inexact | |
9205 | (* (- before-improve before-bind) | |
9206 | clock-granularity))) | |
9207 | (printf | |
9208 | "~a seconds improving,~%" | |
9209 | (exact->inexact | |
9210 | (* (- before-typecheck before-improve) | |
9211 | clock-granularity))) | |
9212 | (printf | |
9213 | "~a seconds type checking,~%" | |
9214 | (exact->inexact | |
9215 | (* (- (- before-output before-typecheck) | |
9216 | visible-time) | |
9217 | clock-granularity))) | |
9218 | (printf | |
9219 | "~a seconds setting visibility,~%" | |
9220 | (exact->inexact | |
9221 | (* visible-time clock-granularity))) | |
9222 | (printf | |
9223 | "~a seconds writing output,~%" | |
9224 | (exact->inexact | |
9225 | (* (- before-end before-output) | |
9226 | clock-granularity))) | |
9227 | (printf | |
9228 | "~a seconds in total.~%" | |
9229 | (exact->inexact | |
9230 | (* (- before-end before-parse) clock-granularity))))))) | |
9231 | (define type-check | |
9232 | (lambda (defs) | |
9233 | (set! tree defs) | |
9234 | (type-defs defs) | |
9235 | defs)) | |
9236 | (define soft-files | |
9237 | (lambda (files output) | |
9238 | (let ((contents | |
9239 | (map (lambda (f) `(begin ,@(readfile f))) files))) | |
9240 | (soft-def `(begin ,@contents) output)))) | |
9241 | (define strip-suffix | |
9242 | (lambda (name) | |
9243 | (let ((n (string-length name))) | |
9244 | (or (and (<= 3 n) | |
9245 | (equal? ".ss" (substring name (- n 3) n)) | |
9246 | (substring name 0 (- n 3))) | |
9247 | (and (<= 4 n) | |
9248 | (equal? ".scm" (substring name (- n 4) n)) | |
9249 | (substring name 0 (- n 4))))))) | |
9250 | (define st:deftype | |
9251 | (match-lambda* | |
9252 | (((? symbol? x) ? list? mutability) | |
9253 | (=> fail) | |
9254 | (if (andmap boolean? mutability) | |
9255 | (deftype x mutability) | |
9256 | (fail))) | |
9257 | (args (use-error | |
9258 | "Invalid command ~a" | |
9259 | `(st:deftype ,@args))))) | |
9260 | (define st:defprim | |
9261 | (match-lambda* | |
9262 | (((? symbol? x) type) (defprim x type 'impure)) | |
9263 | (((? symbol? x) type (? symbol? mode)) | |
9264 | (defprim x type mode)) | |
9265 | (args (use-error | |
9266 | "Invalid command ~a" | |
9267 | `(st:defprim ,@args))))) | |
9268 | (define st:help | |
9269 | (lambda () | |
9270 | (printf | |
9271 | "Commands for Soft Scheme (~a)~%" | |
9272 | st:version) | |
9273 | (printf | |
9274 | " (st: file (output)) type check file and execute~%") | |
9275 | (printf | |
9276 | " (st:type (name)) print types of global defs~%") | |
9277 | (printf | |
9278 | " (st:check file (output)) type check file~%") | |
9279 | (printf | |
9280 | " (st:run file) execute type checked file~%") | |
9281 | (printf | |
9282 | " (st:bench file) execute type checked file fast~%") | |
9283 | (printf | |
9284 | " (st:ltype (name)) print types of local defs~%") | |
9285 | (printf | |
9286 | " (st:cause) print cause of CHECKs~%") | |
9287 | (printf | |
9288 | " (st:summary) print summary of CHECKs~%") | |
9289 | (printf | |
9290 | " (st:help) prints this message~%") | |
9291 | (printf | |
9292 | " (st:defprim name type (mode)) define a new primitive~%") | |
9293 | (printf | |
9294 | " (st:deftype name bool ...) define a new type constructor~%") | |
9295 | (printf | |
9296 | " (st:control flag ...) set internal flags~%") | |
9297 | (printf | |
9298 | "For more info, see ftp://ftp.nj.nec.com/pub/wright/ssmanual/softscheme.html~%") | |
9299 | (printf | |
9300 | "Copyright (c) 1993, 1994, 1995 by Andrew K. Wright under the~%") | |
9301 | (printf | |
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) | |
9306 | (define st:summary | |
9307 | (lambda () (print-summary ""))) | |
9308 | (define init! | |
9309 | (lambda () | |
9310 | (when customization-file | |
9311 | (load (string-append | |
9312 | installation-directory | |
9313 | customization-file))) | |
9314 | (let ((softrc | |
9315 | (string-append home-directory "/.softschemerc"))) | |
9316 | (when (file-exists? softrc) (load softrc))) | |
9317 | (set! global-env initial-env) | |
9318 | (st:help))) | |
9319 | (init!) |