mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity
guile/gc-benchmarks/larceny/softscheme.sch
Ludovic Courtès 1b706edff6 Import GC benchmarks from Larceny, by Hansen, Clinger, et al. 
These GPLv2+-licensed GC benchmarks are available from
http://www.ccs.neu.edu/home/will/GC/sourcecode.html .
2009-01-12 23:31:50 +01:00

9319 lines
390 KiB
Scheme
Raw Permalink Blame History

; Soft Scheme -- Copyright (C) 1993, 1994 Andrew K. Wright
;
; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation; either version 2 of the License, or
; (at your option) any later version.
;
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
; GNU General Public License for more details.
;
; You should have received a copy of the GNU General Public License
; along with this program; if not, write to the Free Software
; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;
; Packaged as a single file for Larceny by Lars T Hansen.
; Modified 2000-02-15 by lth.
;
; Compilation notes.
;
; The macro definitions for MATCH in this file depend on the presence of
; certain helper functions in the compilation environment, eg. match:andmap.
; (That is not a problem when loading this file, but it is an issue when
; compiling it.) The easiest way to provide the helper functions during
; compilation is to load match.sch into the compilation environment before
; compiling.
;
; Once compiled, this program is self-contained.
; The SoftScheme benchmark performs soft typing on a program and prints
; a diagnostic report. All screen output is captured in an output
; string port, which is subsequently discarded. (There is a moderate
; amount of output). No file I/O occurs while the program is running.
(define (softscheme-benchmark)
(let ((expr `(begin ,@(readfile "ss-input.scm")))
(out (open-output-string)))
(run-benchmark "softscheme"
(lambda ()
(with-output-to-port out
(lambda ()
(soft-def expr #f)))))
(newline)
(display (string-length (get-output-string out)))
(display " characters of output written.")
(newline)))
;;; Define defmacro, macro?, and macroexpand-1.
(define *macros* '())
(define-syntax
defmacro
(transformer
(lambda (exp rename compare)
(define (arglist? x)
(or (symbol? x)
(null? x)
(and (pair? x)
(symbol? (car x))
(arglist? (cdr x)))))
(if (not (and (list? exp)
(>= (length exp) 4)
(symbol? (cadr exp))
(arglist? (caddr exp))))
(error "Bad macro definition: " exp))
(let ((name (cadr exp))
(args (caddr exp))
(body (cdddr exp)))
`(begin
(define-syntax
,name
(transformer
(lambda (_defmacro_exp
_defmacro_rename
_defmacro_compare)
(apply (lambda ,args ,@body) (cdr _defmacro_exp)))))
(set! *macros*
(cons (cons ',name
(lambda (_exp)
(apply (lambda ,args ,@body) (cdr _exp))))
*macros*))
)))))
(define (macroexpand-1 exp)
(cond ((pair? exp)
(let ((probe (assq (car exp) *macros*)))
(if probe ((cdr probe) exp) exp)))
(else exp)))
(define (macro? keyword)
(and (symbol? keyword) (assq keyword *macros*)))
;;; Other compatibility hacks
(define slib:error error)
(define force-output flush-output-port)
(define format
(let ((format format))
(lambda (port . rest)
(if (not port)
(let ((s (open-output-string)))
(apply format s rest)
(get-output-string s))
(apply format port rest)))))
(define gentemp
(let ((gensym gensym)) (lambda () (gensym "G"))))
(define getenv
(let ((getenv getenv))
(lambda (x)
(or (getenv x)
(if (string=? x "HOME")
"Ertevann:Desktop folder:"
#f)))))
;;; The rest of the file should be more or less portable.
(define match-file #f)
(define installation-directory #f)
(define customization-file #f)
(define fastlibrary-file #f)
(define st:version
"Larceny Version 0.18, April 21, 1995")
(define match:version
"Version 1.18, July 17, 1995")
(define match:error
(lambda (val . args)
(for-each pretty-print args)
(slib:error "no matching clause for " val)))
(define match:andmap
(lambda (f l)
(if (null? l)
(and)
(and (f (car l)) (match:andmap f (cdr l))))))
(define match:syntax-err
(lambda (obj msg) (slib:error msg obj)))
(define match:disjoint-structure-tags '())
(define match:make-structure-tag
(lambda (name)
(if (or (eq? match:structure-control 'disjoint)
match:runtime-structures)
(let ((tag (gentemp)))
(set! match:disjoint-structure-tags
(cons tag match:disjoint-structure-tags))
tag)
(string->symbol
(string-append "<" (symbol->string name) ">")))))
(define match:structure?
(lambda (tag)
(memq tag match:disjoint-structure-tags)))
(define match:structure-control 'vector)
(define match:set-structure-control
(lambda (v) (set! match:structure-control v)))
(define match:set-error
(lambda (v) (set! match:error v)))
(define match:error-control 'error)
(define match:set-error-control
(lambda (v) (set! match:error-control v)))
(define match:disjoint-predicates
(cons 'null
'(pair? symbol?
boolean?
number?
string?
char?
procedure?
vector?)))
(define match:vector-structures '())
(define match:expanders
(letrec ((genmatch
(lambda (x clauses match-expr)
(let* ((length>= (gentemp))
(eb-errf (error-maker match-expr))
(blist (car eb-errf))
(plist (map (lambda (c)
(let* ((x (bound (validate-pattern
(car c))))
(p (car x))
(bv (cadr x))
(bindings (caddr x))
(code (gentemp))
(fail (and (pair? (cdr c))
(pair? (cadr c))
(eq? (caadr c) '=>)
(symbol? (cadadr c))
(pair? (cdadr c))
(null? (cddadr c))
(pair? (cddr c))
(cadadr c)))
(bv2 (if fail (cons fail bv) bv))
(body (if fail (cddr c) (cdr c))))
(set! blist
(cons `(,code (lambda ,bv2 ,@body))
(append bindings blist)))
(list p
code
bv
(and fail (gentemp))
#f)))
clauses))
(code (gen x
'()
plist
(cdr eb-errf)
length>=
(gentemp))))
(unreachable plist match-expr)
(inline-let
`(let ((,length>=
(lambda (n) (lambda (l) (>= (length l) n))))
,@blist)
,code)))))
(genletrec
(lambda (pat exp body match-expr)
(let* ((length>= (gentemp))
(eb-errf (error-maker match-expr))
(x (bound (validate-pattern pat)))
(p (car x))
(bv (cadr x))
(bindings (caddr x))
(code (gentemp))
(plist (list (list p code bv #f #f)))
(x (gentemp))
(m (gen x
'()
plist
(cdr eb-errf)
length>=
(gentemp)))
(gs (map (lambda (_) (gentemp)) bv)))
(unreachable plist match-expr)
`(letrec ((,length>=
(lambda (n) (lambda (l) (>= (length l) n))))
,@(map (lambda (v) `(,v #f)) bv)
(,x ,exp)
(,code
(lambda ,gs
,@(map (lambda (v g) `(set! ,v ,g)) bv gs)
,@body))
,@bindings
,@(car eb-errf))
,m))))
(gendefine
(lambda (pat exp match-expr)
(let* ((length>= (gentemp))
(eb-errf (error-maker match-expr))
(x (bound (validate-pattern pat)))
(p (car x))
(bv (cadr x))
(bindings (caddr x))
(code (gentemp))
(plist (list (list p code bv #f #f)))
(x (gentemp))
(m (gen x
'()
plist
(cdr eb-errf)
length>=
(gentemp)))
(gs (map (lambda (_) (gentemp)) bv)))
(unreachable plist match-expr)
`(begin
,@(map (lambda (v) `(define ,v #f)) bv)
,(inline-let
`(let ((,length>=
(lambda (n) (lambda (l) (>= (length l) n))))
(,x ,exp)
(,code
(lambda ,gs
,@(map (lambda (v g) `(set! ,v ,g)) bv gs)
(cond (#f #f))))
,@bindings
,@(car eb-errf))
,m))))))
(pattern-var?
(lambda (x)
(and (symbol? x)
(not (dot-dot-k? x))
(not (memq x
'(quasiquote
quote
unquote
unquote-splicing
?
_
$
=
and
or
not
set!
get!
...
___))))))
(dot-dot-k?
(lambda (s)
(and (symbol? s)
(if (memq s '(... ___))
0
(let* ((s (symbol->string s)) (n (string-length s)))
(and (<= 3 n)
(memq (string-ref s 0) '(#\. #\_))
(memq (string-ref s 1) '(#\. #\_))
(match:andmap
char-numeric?
(string->list (substring s 2 n)))
(string->number (substring s 2 n))))))))
(error-maker
(lambda (match-expr)
(cond ((eq? match:error-control 'unspecified)
(cons '() (lambda (x) `(cond (#f #f)))))
((memq match:error-control '(error fail))
(cons '() (lambda (x) `(match:error ,x))))
((eq? match:error-control 'match)
(let ((errf (gentemp)) (arg (gentemp)))
(cons `((,errf
(lambda (,arg)
(match:error ,arg ',match-expr))))
(lambda (x) `(,errf ,x)))))
(else
(match:syntax-err
'(unspecified error fail match)
"invalid value for match:error-control, legal values are")))))
(unreachable
(lambda (plist match-expr)
(for-each
(lambda (x)
(if (not (car (cddddr x)))
(begin
(display "Warning: unreachable pattern ")
(display (car x))
(display " in ")
(display match-expr)
(newline))))
plist)))
(validate-pattern
(lambda (pattern)
(letrec ((simple?
(lambda (x)
(or (string? x)
(boolean? x)
(char? x)
(number? x)
(null? x))))
(ordinary
(lambda (p)
(let ((g88 (lambda (x y)
(cons (ordinary x) (ordinary y)))))
(if (simple? p)
((lambda (p) p) p)
(if (equal? p '_)
((lambda () '_))
(if (pattern-var? p)
((lambda (p) p) p)
(if (pair? p)
(if (equal? (car p) 'quasiquote)
(if (and (pair? (cdr p))
(null? (cddr p)))
((lambda (p) (quasi p)) (cadr p))
(g88 (car p) (cdr p)))
(if (equal? (car p) 'quote)
(if (and (pair? (cdr p))
(null? (cddr p)))
((lambda (p) p) p)
(g88 (car p) (cdr p)))
(if (equal? (car p) '?)
(if (and (pair? (cdr p))
(list? (cddr p)))
((lambda (pred ps)
`(? ,pred
,@(map ordinary ps)))
(cadr p)
(cddr p))
(g88 (car p) (cdr p)))
(if (equal? (car p) '=)
(if (and (pair? (cdr p))
(pair? (cddr p))
(null? (cdddr p)))
((lambda (sel p)
`(= ,sel ,(ordinary p)))
(cadr p)
(caddr p))
(g88 (car p) (cdr p)))
(if (equal? (car p) 'and)
(if (and (list? (cdr p))
(pair? (cdr p)))
((lambda (ps)
`(and ,@(map ordinary
ps)))
(cdr p))
(g88 (car p) (cdr p)))
(if (equal? (car p) 'or)
(if (and (list? (cdr p))
(pair? (cdr p)))
((lambda (ps)
`(or ,@(map ordinary
ps)))
(cdr p))
(g88 (car p) (cdr p)))
(if (equal? (car p) 'not)
(if (and (list? (cdr p))
(pair? (cdr p)))
((lambda (ps)
`(not ,@(map ordinary
ps)))
(cdr p))
(g88 (car p) (cdr p)))
(if (equal? (car p) '$)
(if (and (pair? (cdr p))
(symbol?
(cadr p))
(list? (cddr p)))
((lambda (r ps)
`($ ,r
,@(map ordinary
ps)))
(cadr p)
(cddr p))
(g88 (car p) (cdr p)))
(if (equal?
(car p)
'set!)
(if (and (pair? (cdr p))
(pattern-var?
(cadr p))
(null? (cddr p)))
((lambda (p) p) p)
(g88 (car p)
(cdr p)))
(if (equal?
(car p)
'get!)
(if (and (pair? (cdr p))
(pattern-var?
(cadr p))
(null? (cddr p)))
((lambda (p) p) p)
(g88 (car p)
(cdr p)))
(if (equal?
(car p)
'unquote)
(g88 (car p)
(cdr p))
(if (equal?
(car p)
'unquote-splicing)
(g88 (car p)
(cdr p))
(if (and (pair? (cdr p))
(dot-dot-k?
(cadr p))
(null? (cddr p)))
((lambda (p
ddk)
`(,(ordinary
p)
,ddk))
(car p)
(cadr p))
(g88 (car p)
(cdr p)))))))))))))))
(if (vector? p)
((lambda (p)
(let* ((pl (vector->list p))
(rpl (reverse pl)))
(apply vector
(if (and (not (null? rpl))
(dot-dot-k?
(car rpl)))
(reverse
(cons (car rpl)
(map ordinary
(cdr rpl))))
(map ordinary pl)))))
p)
((lambda ()
(match:syntax-err
pattern
"syntax error in pattern")))))))))))
(quasi (lambda (p)
(let ((g109 (lambda (x y)
(cons (quasi x) (quasi y)))))
(if (simple? p)
((lambda (p) p) p)
(if (symbol? p)
((lambda (p) `',p) p)
(if (pair? p)
(if (equal? (car p) 'unquote)
(if (and (pair? (cdr p))
(null? (cddr p)))
((lambda (p) (ordinary p))
(cadr p))
(g109 (car p) (cdr p)))
(if (and (pair? (car p))
(equal?
(caar p)
'unquote-splicing)
(pair? (cdar p))
(null? (cddar p)))
(if (null? (cdr p))
((lambda (p) (ordinary p))
(cadar p))
((lambda (p y)
(append
(ordlist p)
(quasi y)))
(cadar p)
(cdr p)))
(if (and (pair? (cdr p))
(dot-dot-k? (cadr p))
(null? (cddr p)))
((lambda (p ddk)
`(,(quasi p) ,ddk))
(car p)
(cadr p))
(g109 (car p) (cdr p)))))
(if (vector? p)
((lambda (p)
(let* ((pl (vector->list p))
(rpl (reverse pl)))
(apply vector
(if (dot-dot-k?
(car rpl))
(reverse
(cons (car rpl)
(map quasi
(cdr rpl))))
(map ordinary pl)))))
p)
((lambda ()
(match:syntax-err
pattern
"syntax error in pattern"))))))))))
(ordlist
(lambda (p)
(cond ((null? p) '())
((pair? p)
(cons (ordinary (car p)) (ordlist (cdr p))))
(else
(match:syntax-err
pattern
"invalid use of unquote-splicing in pattern"))))))
(ordinary pattern))))
(bound (lambda (pattern)
(letrec ((pred-bodies '())
(bound (lambda (p a k)
(cond ((eq? '_ p) (k p a))
((symbol? p)
(if (memq p a)
(match:syntax-err
pattern
"duplicate variable in pattern"))
(k p (cons p a)))
((and (pair? p)
(eq? 'quote (car p)))
(k p a))
((and (pair? p) (eq? '? (car p)))
(cond ((not (null? (cddr p)))
(bound `(and (? ,(cadr p))
,@(cddr p))
a
k))
((or (not (symbol?
(cadr p)))
(memq (cadr p) a))
(let ((g (gentemp)))
(set! pred-bodies
(cons `(,g ,(cadr p))
pred-bodies))
(k `(? ,g) a)))
(else (k p a))))
((and (pair? p) (eq? '= (car p)))
(cond ((or (not (symbol?
(cadr p)))
(memq (cadr p) a))
(let ((g (gentemp)))
(set! pred-bodies
(cons `(,g ,(cadr p))
pred-bodies))
(bound `(= ,g ,(caddr p))
a
k)))
(else
(bound (caddr p)
a
(lambda (p2 a)
(k `(= ,(cadr p)
,p2)
a))))))
((and (pair? p) (eq? 'and (car p)))
(bound*
(cdr p)
a
(lambda (p a)
(k `(and ,@p) a))))
((and (pair? p) (eq? 'or (car p)))
(bound (cadr p)
a
(lambda (first-p first-a)
(let or* ((plist (cddr p))
(k (lambda (plist)
(k `(or ,first-p
,@plist)
first-a))))
(if (null? plist)
(k plist)
(bound (car plist)
a
(lambda (car-p
car-a)
(if (not (permutation
car-a
first-a))
(match:syntax-err
pattern
"variables of or-pattern differ in"))
(or* (cdr plist)
(lambda (cdr-p)
(k (cons car-p
cdr-p)))))))))))
((and (pair? p) (eq? 'not (car p)))
(cond ((not (null? (cddr p)))
(bound `(not (or ,@(cdr p)))
a
k))
(else
(bound (cadr p)
a
(lambda (p2 a2)
(if (not (permutation
a
a2))
(match:syntax-err
p
"no variables allowed in"))
(k `(not ,p2)
a))))))
((and (pair? p)
(pair? (cdr p))
(dot-dot-k? (cadr p)))
(bound (car p)
a
(lambda (q b)
(let ((bvars (find-prefix
b
a)))
(k `(,q
,(cadr p)
,bvars
,(gentemp)
,(gentemp)
,(map (lambda (_)
(gentemp))
bvars))
b)))))
((and (pair? p) (eq? '$ (car p)))
(bound*
(cddr p)
a
(lambda (p1 a)
(k `($ ,(cadr p) ,@p1) a))))
((and (pair? p)
(eq? 'set! (car p)))
(if (memq (cadr p) a)
(k p a)
(k p (cons (cadr p) a))))
((and (pair? p)
(eq? 'get! (car p)))
(if (memq (cadr p) a)
(k p a)
(k p (cons (cadr p) a))))
((pair? p)
(bound (car p)
a
(lambda (car-p a)
(bound (cdr p)
a
(lambda (cdr-p a)
(k (cons car-p
cdr-p)
a))))))
((vector? p)
(boundv
(vector->list p)
a
(lambda (pl a)
(k (list->vector pl) a))))
(else (k p a)))))
(boundv
(lambda (plist a k)
(let ((g115 (lambda () (k plist a))))
(if (pair? plist)
(if (and (pair? (cdr plist))
(dot-dot-k? (cadr plist))
(null? (cddr plist)))
((lambda () (bound plist a k)))
(if (null? plist)
(g115)
((lambda (x y)
(bound x
a
(lambda (car-p a)
(boundv
y
a
(lambda (cdr-p a)
(k (cons car-p cdr-p)
a))))))
(car plist)
(cdr plist))))
(if (null? plist)
(g115)
(match:error plist))))))
(bound*
(lambda (plist a k)
(if (null? plist)
(k plist a)
(bound (car plist)
a
(lambda (car-p a)
(bound*
(cdr plist)
a
(lambda (cdr-p a)
(k (cons car-p cdr-p) a))))))))
(find-prefix
(lambda (b a)
(if (eq? b a)
'()
(cons (car b) (find-prefix (cdr b) a)))))
(permutation
(lambda (p1 p2)
(and (= (length p1) (length p2))
(match:andmap
(lambda (x1) (memq x1 p2))
p1)))))
(bound pattern
'()
(lambda (p a)
(list p (reverse a) pred-bodies))))))
(inline-let
(lambda (let-exp)
(letrec ((occ (lambda (x e)
(let loop ((e e))
(cond ((pair? e)
(+ (loop (car e)) (loop (cdr e))))
((eq? x e) 1)
(else 0)))))
(subst (lambda (e old new)
(let loop ((e e))
(cond ((pair? e)
(cons (loop (car e)) (loop (cdr e))))
((eq? old e) new)
(else e)))))
(const?
(lambda (sexp)
(or (symbol? sexp)
(boolean? sexp)
(string? sexp)
(char? sexp)
(number? sexp)
(null? sexp)
(and (pair? sexp)
(eq? (car sexp) 'quote)
(pair? (cdr sexp))
(symbol? (cadr sexp))
(null? (cddr sexp))))))
(isval?
(lambda (sexp)
(or (const? sexp)
(and (pair? sexp)
(memq (car sexp)
'(lambda quote
match-lambda
match-lambda*))))))
(small?
(lambda (sexp)
(or (const? sexp)
(and (pair? sexp)
(eq? (car sexp) 'lambda)
(pair? (cdr sexp))
(pair? (cddr sexp))
(const? (caddr sexp))
(null? (cdddr sexp)))))))
(let loop ((b (cadr let-exp))
(new-b '())
(e (caddr let-exp)))
(cond ((null? b)
(if (null? new-b) e `(let ,(reverse new-b) ,e)))
((isval? (cadr (car b)))
(let* ((x (caar b)) (n (occ x e)))
(cond ((= 0 n) (loop (cdr b) new-b e))
((or (= 1 n) (small? (cadr (car b))))
(loop (cdr b)
new-b
(subst e x (cadr (car b)))))
(else
(loop (cdr b) (cons (car b) new-b) e)))))
(else (loop (cdr b) (cons (car b) new-b) e)))))))
(gen (lambda (x sf plist erract length>= eta)
(if (null? plist)
(erract x)
(let* ((v '())
(val (lambda (x) (cdr (assq x v))))
(fail (lambda (sf)
(gen x sf (cdr plist) erract length>= eta)))
(success
(lambda (sf)
(set-car! (cddddr (car plist)) #t)
(let* ((code (cadr (car plist)))
(bv (caddr (car plist)))
(fail-sym (cadddr (car plist))))
(if fail-sym
(let ((ap `(,code
,fail-sym
,@(map val bv))))
`(call-with-current-continuation
(lambda (,fail-sym)
(let ((,fail-sym
(lambda ()
(,fail-sym ,(fail sf)))))
,ap))))
`(,code ,@(map val bv)))))))
(let next ((p (caar plist))
(e x)
(sf sf)
(kf fail)
(ks success))
(cond ((eq? '_ p) (ks sf))
((symbol? p)
(set! v (cons (cons p e) v))
(ks sf))
((null? p) (emit `(null? ,e) sf kf ks))
((equal? p ''()) (emit `(null? ,e) sf kf ks))
((string? p) (emit `(equal? ,e ,p) sf kf ks))
((boolean? p) (emit `(equal? ,e ,p) sf kf ks))
((char? p) (emit `(equal? ,e ,p) sf kf ks))
((number? p) (emit `(equal? ,e ,p) sf kf ks))
((and (pair? p) (eq? 'quote (car p)))
(emit `(equal? ,e ,p) sf kf ks))
((and (pair? p) (eq? '? (car p)))
(let ((tst `(,(cadr p) ,e)))
(emit tst sf kf ks)))
((and (pair? p) (eq? '= (car p)))
(next (caddr p) `(,(cadr p) ,e) sf kf ks))
((and (pair? p) (eq? 'and (car p)))
(let loop ((p (cdr p)) (sf sf))
(if (null? p)
(ks sf)
(next (car p)
e
sf
kf
(lambda (sf) (loop (cdr p) sf))))))
((and (pair? p) (eq? 'or (car p)))
(let ((or-v v))
(let loop ((p (cdr p)) (sf sf))
(if (null? p)
(kf sf)
(begin
(set! v or-v)
(next (car p)
e
sf
(lambda (sf) (loop (cdr p) sf))
ks))))))
((and (pair? p) (eq? 'not (car p)))
(next (cadr p) e sf ks kf))
((and (pair? p) (eq? '$ (car p)))
(let* ((tag (cadr p))
(fields (cdr p))
(rlen (length fields))
(tst `(,(symbol-append tag '?) ,e)))
(emit tst
sf
kf
(let rloop ((n 1))
(lambda (sf)
(if (= n rlen)
(ks sf)
(next (list-ref fields n)
`(,(symbol-append tag '- n)
,e)
sf
kf
(rloop (+ 1 n)))))))))
((and (pair? p) (eq? 'set! (car p)))
(set! v (cons (cons (cadr p) (setter e p)) v))
(ks sf))
((and (pair? p) (eq? 'get! (car p)))
(set! v (cons (cons (cadr p) (getter e p)) v))
(ks sf))
((and (pair? p)
(pair? (cdr p))
(dot-dot-k? (cadr p)))
(emit `(list? ,e)
sf
kf
(lambda (sf)
(let* ((k (dot-dot-k? (cadr p)))
(ks (lambda (sf)
(let ((bound (list-ref
p
2)))
(cond ((eq? (car p) '_)
(ks sf))
((null? bound)
(let* ((ptst (next (car p)
eta
sf
(lambda (sf)
#f)
(lambda (sf)
#t)))
(tst (if (and (pair? ptst)
(symbol?
(car ptst))
(pair? (cdr ptst))
(eq? eta
(cadr ptst))
(null? (cddr ptst)))
(car ptst)
`(lambda (,eta)
,ptst))))
(assm `(match:andmap
,tst
,e)
(kf sf)
(ks sf))))
((and (symbol?
(car p))
(equal?
(list (car p))
bound))
(next (car p)
e
sf
kf
ks))
(else
(let* ((gloop (list-ref
p
3))
(ge (list-ref
p
4))
(fresh (list-ref
p
5))
(p1 (next (car p)
`(car ,ge)
sf
kf
(lambda (sf)
`(,gloop
(cdr ,ge)
,@(map (lambda (b
f)
`(cons ,(val b)
,f))
bound
fresh))))))
(set! v
(append
(map cons
bound
(map (lambda (x)
`(reverse
,x))
fresh))
v))
`(let ,gloop
((,ge ,e)
,@(map (lambda (x)
`(,x
'()))
fresh))
(if (null? ,ge)
,(ks sf)
,p1)))))))))
(case k
((0) (ks sf))
((1) (emit `(pair? ,e) sf kf ks))
(else
(emit `((,length>= ,k) ,e)
sf
kf
ks)))))))
((pair? p)
(emit `(pair? ,e)
sf
kf
(lambda (sf)
(next (car p)
(add-a e)
sf
kf
(lambda (sf)
(next (cdr p)
(add-d e)
sf
kf
ks))))))
((and (vector? p)
(>= (vector-length p) 6)
(dot-dot-k?
(vector-ref p (- (vector-length p) 5))))
(let* ((vlen (- (vector-length p) 6))
(k (dot-dot-k?
(vector-ref p (+ vlen 1))))
(minlen (+ vlen k))
(bound (vector-ref p (+ vlen 2))))
(emit `(vector? ,e)
sf
kf
(lambda (sf)
(assm `(>= (vector-length ,e) ,minlen)
(kf sf)
((let vloop ((n 0))
(lambda (sf)
(cond ((not (= n vlen))
(next (vector-ref
p
n)
`(vector-ref
,e
,n)
sf
kf
(vloop (+ 1
n))))
((eq? (vector-ref
p
vlen)
'_)
(ks sf))
(else
(let* ((gloop (vector-ref
p
(+ vlen
3)))
(ind (vector-ref
p
(+ vlen
4)))
(fresh (vector-ref
p
(+ vlen
5)))
(p1 (next (vector-ref
p
vlen)
`(vector-ref
,e
,ind)
sf
kf
(lambda (sf)
`(,gloop
(- ,ind
1)
,@(map (lambda (b
f)
`(cons ,(val b)
,f))
bound
fresh))))))
(set! v
(append
(map cons
bound
fresh)
v))
`(let ,gloop
((,ind
(- (vector-length
,e)
1))
,@(map (lambda (x)
`(,x
'()))
fresh))
(if (> ,minlen
,ind)
,(ks sf)
,p1)))))))
sf))))))
((vector? p)
(let ((vlen (vector-length p)))
(emit `(vector? ,e)
sf
kf
(lambda (sf)
(emit `(equal?
(vector-length ,e)
,vlen)
sf
kf
(let vloop ((n 0))
(lambda (sf)
(if (= n vlen)
(ks sf)
(next (vector-ref p n)
`(vector-ref ,e ,n)
sf
kf
(vloop (+ 1
n)))))))))))
(else
(display "FATAL ERROR IN PATTERN MATCHER")
(newline)
(error #f "THIS NEVER HAPPENS"))))))))
(emit (lambda (tst sf kf ks)
(cond ((in tst sf) (ks sf))
((in `(not ,tst) sf) (kf sf))
(else
(let* ((e (cadr tst))
(implied
(cond ((eq? (car tst) 'equal?)
(let ((p (caddr tst)))
(cond ((string? p) `((string? ,e)))
((boolean? p)
`((boolean? ,e)))
((char? p) `((char? ,e)))
((number? p) `((number? ,e)))
((and (pair? p)
(eq? 'quote (car p)))
`((symbol? ,e)))
(else '()))))
((eq? (car tst) 'null?) `((list? ,e)))
((vec-structure? tst) `((vector? ,e)))
(else '())))
(not-imp
(case (car tst)
((list?) `((not (null? ,e))))
(else '())))
(s (ks (cons tst (append implied sf))))
(k (kf (cons `(not ,tst)
(append not-imp sf)))))
(assm tst k s))))))
(assm (lambda (tst f s)
(cond ((equal? s f) s)
((and (eq? s #t) (eq? f #f)) tst)
((and (eq? (car tst) 'pair?)
(memq match:error-control '(unspecified fail))
(memq (car f) '(cond match:error))
(guarantees s (cadr tst)))
s)
((and (pair? s)
(eq? (car s) 'if)
(equal? (cadddr s) f))
(if (eq? (car (cadr s)) 'and)
`(if (and ,tst ,@(cdr (cadr s))) ,(caddr s) ,f)
`(if (and ,tst ,(cadr s)) ,(caddr s) ,f)))
((and (pair? s)
(equal? (car s) 'call-with-current-continuation)
(pair? (cdr s))
(pair? (cadr s))
(equal? (caadr s) 'lambda)
(pair? (cdadr s))
(pair? (cadadr s))
(null? (cdr (cadadr s)))
(pair? (cddadr s))
(pair? (car (cddadr s)))
(equal? (caar (cddadr s)) 'let)
(pair? (cdar (cddadr s)))
(pair? (cadar (cddadr s)))
(pair? (caadar (cddadr s)))
(pair? (cdr (caadar (cddadr s))))
(pair? (cadr (caadar (cddadr s))))
(equal? (caadr (caadar (cddadr s))) 'lambda)
(pair? (cdadr (caadar (cddadr s))))
(null? (cadadr (caadar (cddadr s))))
(pair? (cddadr (caadar (cddadr s))))
(pair? (car (cddadr (caadar (cddadr s)))))
(pair? (cdar (cddadr (caadar (cddadr s)))))
(null? (cddar (cddadr (caadar (cddadr s)))))
(null? (cdr (cddadr (caadar (cddadr s)))))
(null? (cddr (caadar (cddadr s))))
(null? (cdadar (cddadr s)))
(pair? (cddar (cddadr s)))
(null? (cdddar (cddadr s)))
(null? (cdr (cddadr s)))
(null? (cddr s))
(equal? f (cadar (cddadr (caadar (cddadr s))))))
(let ((k (car (cadadr s)))
(fail (car (caadar (cddadr s))))
(s2 (caddar (cddadr s))))
`(call-with-current-continuation
(lambda (,k)
(let ((,fail (lambda () (,k ,f))))
,(assm tst `(,fail) s2))))))
((and #f
(pair? s)
(equal? (car s) 'let)
(pair? (cdr s))
(pair? (cadr s))
(pair? (caadr s))
(pair? (cdaadr s))
(pair? (car (cdaadr s)))
(equal? (caar (cdaadr s)) 'lambda)
(pair? (cdar (cdaadr s)))
(null? (cadar (cdaadr s)))
(pair? (cddar (cdaadr s)))
(null? (cdddar (cdaadr s)))
(null? (cdr (cdaadr s)))
(null? (cdadr s))
(pair? (cddr s))
(null? (cdddr s))
(equal? (caddar (cdaadr s)) f))
(let ((fail (caaadr s)) (s2 (caddr s)))
`(let ((,fail (lambda () ,f)))
,(assm tst `(,fail) s2))))
(else `(if ,tst ,s ,f)))))
(guarantees
(lambda (code x)
(let ((a (add-a x)) (d (add-d x)))
(let loop ((code code))
(cond ((not (pair? code)) #f)
((memq (car code) '(cond match:error)) #t)
((or (equal? code a) (equal? code d)) #t)
((eq? (car code) 'if)
(or (loop (cadr code))
(and (loop (caddr code)) (loop (cadddr code)))))
((eq? (car code) 'lambda) #f)
((and (eq? (car code) 'let) (symbol? (cadr code)))
#f)
(else (or (loop (car code)) (loop (cdr code)))))))))
(in (lambda (e l)
(or (member e l)
(and (eq? (car e) 'list?)
(or (member `(null? ,(cadr e)) l)
(member `(pair? ,(cadr e)) l)))
(and (eq? (car e) 'not)
(let* ((srch (cadr e))
(const-class (equal-test? srch)))
(cond (const-class
(let mem ((l l))
(if (null? l)
#f
(let ((x (car l)))
(or (and (equal? (cadr x) (cadr srch))
(disjoint? x)
(not (equal?
const-class
(car x))))
(equal?
x
`(not (,const-class
,(cadr srch))))
(and (equal? (cadr x) (cadr srch))
(equal-test? x)
(not (equal?
(caddr srch)
(caddr x))))
(mem (cdr l)))))))
((disjoint? srch)
(let mem ((l l))
(if (null? l)
#f
(let ((x (car l)))
(or (and (equal? (cadr x) (cadr srch))
(disjoint? x)
(not (equal?
(car x)
(car srch))))
(mem (cdr l)))))))
((eq? (car srch) 'list?)
(let mem ((l l))
(if (null? l)
#f
(let ((x (car l)))
(or (and (equal? (cadr x) (cadr srch))
(disjoint? x)
(not (memq (car x)
'(list? pair?
null?))))
(mem (cdr l)))))))
((vec-structure? srch)
(let mem ((l l))
(if (null? l)
#f
(let ((x (car l)))
(or (and (equal? (cadr x) (cadr srch))
(or (disjoint? x)
(vec-structure? x))
(not (equal?
(car x)
'vector?))
(not (equal?
(car x)
(car srch))))
(equal?
x
`(not (vector? ,(cadr srch))))
(mem (cdr l)))))))
(else #f)))))))
(equal-test?
(lambda (tst)
(and (eq? (car tst) 'equal?)
(let ((p (caddr tst)))
(cond ((string? p) 'string?)
((boolean? p) 'boolean?)
((char? p) 'char?)
((number? p) 'number?)
((and (pair? p)
(pair? (cdr p))
(null? (cddr p))
(eq? 'quote (car p))
(symbol? (cadr p)))
'symbol?)
(else #f))))))
(disjoint?
(lambda (tst)
(memq (car tst) match:disjoint-predicates)))
(vec-structure?
(lambda (tst)
(memq (car tst) match:vector-structures)))
(add-a (lambda (a)
(let ((new (and (pair? a) (assq (car a) c---rs))))
(if new (cons (cadr new) (cdr a)) `(car ,a)))))
(add-d (lambda (a)
(let ((new (and (pair? a) (assq (car a) c---rs))))
(if new (cons (cddr new) (cdr a)) `(cdr ,a)))))
(c---rs
'((car caar . cdar)
(cdr cadr . cddr)
(caar caaar . cdaar)
(cadr caadr . cdadr)
(cdar cadar . cddar)
(cddr caddr . cdddr)
(caaar caaaar . cdaaar)
(caadr caaadr . cdaadr)
(cadar caadar . cdadar)
(caddr caaddr . cdaddr)
(cdaar cadaar . cddaar)
(cdadr cadadr . cddadr)
(cddar caddar . cdddar)
(cdddr cadddr . cddddr)))
(setter
(lambda (e p)
(let ((mk-setter
(lambda (s) (symbol-append 'set- s '!))))
(cond ((not (pair? e))
(match:syntax-err p "unnested set! pattern"))
((eq? (car e) 'vector-ref)
`(let ((x ,(cadr e)))
(lambda (y) (vector-set! x ,(caddr e) y))))
((eq? (car e) 'unbox)
`(let ((x ,(cadr e))) (lambda (y) (set-box! x y))))
((eq? (car e) 'car)
`(let ((x ,(cadr e))) (lambda (y) (set-car! x y))))
((eq? (car e) 'cdr)
`(let ((x ,(cadr e))) (lambda (y) (set-cdr! x y))))
((let ((a (assq (car e) get-c---rs)))
(and a
`(let ((x (,(cadr a) ,(cadr e))))
(lambda (y) (,(mk-setter (cddr a)) x y))))))
(else
`(let ((x ,(cadr e)))
(lambda (y) (,(mk-setter (car e)) x y))))))))
(getter
(lambda (e p)
(cond ((not (pair? e))
(match:syntax-err p "unnested get! pattern"))
((eq? (car e) 'vector-ref)
`(let ((x ,(cadr e)))
(lambda () (vector-ref x ,(caddr e)))))
((eq? (car e) 'unbox)
`(let ((x ,(cadr e))) (lambda () (unbox x))))
((eq? (car e) 'car)
`(let ((x ,(cadr e))) (lambda () (car x))))
((eq? (car e) 'cdr)
`(let ((x ,(cadr e))) (lambda () (cdr x))))
((let ((a (assq (car e) get-c---rs)))
(and a
`(let ((x (,(cadr a) ,(cadr e))))
(lambda () (,(cddr a) x))))))
(else
`(let ((x ,(cadr e))) (lambda () (,(car e) x)))))))
(get-c---rs
'((caar car . car)
(cadr cdr . car)
(cdar car . cdr)
(cddr cdr . cdr)
(caaar caar . car)
(caadr cadr . car)
(cadar cdar . car)
(caddr cddr . car)
(cdaar caar . cdr)
(cdadr cadr . cdr)
(cddar cdar . cdr)
(cdddr cddr . cdr)
(caaaar caaar . car)
(caaadr caadr . car)
(caadar cadar . car)
(caaddr caddr . car)
(cadaar cdaar . car)
(cadadr cdadr . car)
(caddar cddar . car)
(cadddr cdddr . car)
(cdaaar caaar . cdr)
(cdaadr caadr . cdr)
(cdadar cadar . cdr)
(cdaddr caddr . cdr)
(cddaar cdaar . cdr)
(cddadr cdadr . cdr)
(cdddar cddar . cdr)
(cddddr cdddr . cdr)))
(symbol-append
(lambda l
(string->symbol
(apply string-append
(map (lambda (x)
(cond ((symbol? x) (symbol->string x))
((number? x) (number->string x))
(else x)))
l)))))
(rac (lambda (l)
(if (null? (cdr l)) (car l) (rac (cdr l)))))
(rdc (lambda (l)
(if (null? (cdr l))
'()
(cons (car l) (rdc (cdr l)))))))
(list genmatch genletrec gendefine pattern-var?)))
(defmacro
match
args
(cond ((and (list? args)
(<= 1 (length args))
(match:andmap
(lambda (y) (and (list? y) (<= 2 (length y))))
(cdr args)))
(let* ((exp (car args))
(clauses (cdr args))
(e (if (symbol? exp) exp (gentemp))))
(if (symbol? exp)
((car match:expanders) e clauses `(match ,@args))
`(let ((,e ,exp))
,((car match:expanders) e clauses `(match ,@args))))))
(else
(match:syntax-err
`(match ,@args)
"syntax error in"))))
(defmacro
match-lambda
args
(if (and (list? args)
(match:andmap
(lambda (g126)
(if (and (pair? g126) (list? (cdr g126)))
(pair? (cdr g126))
#f))
args))
((lambda ()
(let ((e (gentemp)))
`(lambda (,e) (match ,e ,@args)))))
((lambda ()
(match:syntax-err
`(match-lambda ,@args)
"syntax error in")))))
(defmacro
match-lambda*
args
(if (and (list? args)
(match:andmap
(lambda (g134)
(if (and (pair? g134) (list? (cdr g134)))
(pair? (cdr g134))
#f))
args))
((lambda ()
(let ((e (gentemp)))
`(lambda ,e (match ,e ,@args)))))
((lambda ()
(match:syntax-err
`(match-lambda* ,@args)
"syntax error in")))))
(defmacro
match-let
args
(let ((g158 (lambda (pat exp body)
`(match ,exp (,pat ,@body))))
(g154 (lambda (pat exp body)
(let ((g (map (lambda (x) (gentemp)) pat))
(vpattern (list->vector pat)))
`(let ,(map list g exp)
(match (vector ,@g) (,vpattern ,@body))))))
(g146 (lambda ()
(match:syntax-err
`(match-let ,@args)
"syntax error in")))
(g145 (lambda (p1 e1 p2 e2 body)
(let ((g1 (gentemp)) (g2 (gentemp)))
`(let ((,g1 ,e1) (,g2 ,e2))
(match (cons ,g1 ,g2) ((,p1 unquote p2) ,@body))))))
(g136 (cadddr match:expanders)))
(if (pair? args)
(if (symbol? (car args))
(if (and (pair? (cdr args)) (list? (cadr args)))
(let g161 ((g162 (cadr args)) (g160 '()) (g159 '()))
(if (null? g162)
(if (and (list? (cddr args)) (pair? (cddr args)))
((lambda (name pat exp body)
(if (match:andmap (cadddr match:expanders) pat)
`(let ,@args)
`(letrec ((,name (match-lambda* (,pat ,@body))))
(,name ,@exp))))
(car args)
(reverse g159)
(reverse g160)
(cddr args))
(g146))
(if (and (pair? (car g162))
(pair? (cdar g162))
(null? (cddar g162)))
(g161 (cdr g162)
(cons (cadar g162) g160)
(cons (caar g162) g159))
(g146))))
(g146))
(if (list? (car args))
(if (match:andmap
(lambda (g167)
(if (and (pair? g167)
(g136 (car g167))
(pair? (cdr g167)))
(null? (cddr g167))
#f))
(car args))
(if (and (list? (cdr args)) (pair? (cdr args)))
((lambda () `(let ,@args)))
(let g149 ((g150 (car args)) (g148 '()) (g147 '()))
(if (null? g150)
(g146)
(if (and (pair? (car g150))
(pair? (cdar g150))
(null? (cddar g150)))
(g149 (cdr g150)
(cons (cadar g150) g148)
(cons (caar g150) g147))
(g146)))))
(if (and (pair? (car args))
(pair? (caar args))
(pair? (cdaar args))
(null? (cddaar args)))
(if (null? (cdar args))
(if (and (list? (cdr args)) (pair? (cdr args)))
(g158 (caaar args) (cadaar args) (cdr args))
(let g149 ((g150 (car args)) (g148 '()) (g147 '()))
(if (null? g150)
(g146)
(if (and (pair? (car g150))
(pair? (cdar g150))
(null? (cddar g150)))
(g149 (cdr g150)
(cons (cadar g150) g148)
(cons (caar g150) g147))
(g146)))))
(if (and (pair? (cdar args))
(pair? (cadar args))
(pair? (cdadar args))
(null? (cdr (cdadar args)))
(null? (cddar args)))
(if (and (list? (cdr args)) (pair? (cdr args)))
(g145 (caaar args)
(cadaar args)
(caadar args)
(car (cdadar args))
(cdr args))
(let g149 ((g150 (car args)) (g148 '()) (g147 '()))
(if (null? g150)
(g146)
(if (and (pair? (car g150))
(pair? (cdar g150))
(null? (cddar g150)))
(g149 (cdr g150)
(cons (cadar g150) g148)
(cons (caar g150) g147))
(g146)))))
(let g149 ((g150 (car args)) (g148 '()) (g147 '()))
(if (null? g150)
(if (and (list? (cdr args)) (pair? (cdr args)))
(g154 (reverse g147) (reverse g148) (cdr args))
(g146))
(if (and (pair? (car g150))
(pair? (cdar g150))
(null? (cddar g150)))
(g149 (cdr g150)
(cons (cadar g150) g148)
(cons (caar g150) g147))
(g146))))))
(let g149 ((g150 (car args)) (g148 '()) (g147 '()))
(if (null? g150)
(if (and (list? (cdr args)) (pair? (cdr args)))
(g154 (reverse g147) (reverse g148) (cdr args))
(g146))
(if (and (pair? (car g150))
(pair? (cdar g150))
(null? (cddar g150)))
(g149 (cdr g150)
(cons (cadar g150) g148)
(cons (caar g150) g147))
(g146))))))
(if (pair? (car args))
(if (and (pair? (caar args))
(pair? (cdaar args))
(null? (cddaar args)))
(if (null? (cdar args))
(if (and (list? (cdr args)) (pair? (cdr args)))
(g158 (caaar args) (cadaar args) (cdr args))
(let g149 ((g150 (car args)) (g148 '()) (g147 '()))
(if (null? g150)
(g146)
(if (and (pair? (car g150))
(pair? (cdar g150))
(null? (cddar g150)))
(g149 (cdr g150)
(cons (cadar g150) g148)
(cons (caar g150) g147))
(g146)))))
(if (and (pair? (cdar args))
(pair? (cadar args))
(pair? (cdadar args))
(null? (cdr (cdadar args)))
(null? (cddar args)))
(if (and (list? (cdr args)) (pair? (cdr args)))
(g145 (caaar args)
(cadaar args)
(caadar args)
(car (cdadar args))
(cdr args))
(let g149 ((g150 (car args)) (g148 '()) (g147 '()))
(if (null? g150)
(g146)
(if (and (pair? (car g150))
(pair? (cdar g150))
(null? (cddar g150)))
(g149 (cdr g150)
(cons (cadar g150) g148)
(cons (caar g150) g147))
(g146)))))
(let g149 ((g150 (car args)) (g148 '()) (g147 '()))
(if (null? g150)
(if (and (list? (cdr args)) (pair? (cdr args)))
(g154 (reverse g147) (reverse g148) (cdr args))
(g146))
(if (and (pair? (car g150))
(pair? (cdar g150))
(null? (cddar g150)))
(g149 (cdr g150)
(cons (cadar g150) g148)
(cons (caar g150) g147))
(g146))))))
(let g149 ((g150 (car args)) (g148 '()) (g147 '()))
(if (null? g150)
(if (and (list? (cdr args)) (pair? (cdr args)))
(g154 (reverse g147) (reverse g148) (cdr args))
(g146))
(if (and (pair? (car g150))
(pair? (cdar g150))
(null? (cddar g150)))
(g149 (cdr g150)
(cons (cadar g150) g148)
(cons (caar g150) g147))
(g146)))))
(g146))))
(g146))))
(defmacro
match-let*
args
(let ((g176 (lambda ()
(match:syntax-err
`(match-let* ,@args)
"syntax error in"))))
(if (pair? args)
(if (null? (car args))
(if (and (list? (cdr args)) (pair? (cdr args)))
((lambda (body) `(let* ,@args)) (cdr args))
(g176))
(if (and (pair? (car args))
(pair? (caar args))
(pair? (cdaar args))
(null? (cddaar args))
(list? (cdar args))
(list? (cdr args))
(pair? (cdr args)))
((lambda (pat exp rest body)
(if ((cadddr match:expanders) pat)
`(let ((,pat ,exp)) (match-let* ,rest ,@body))
`(match ,exp (,pat (match-let* ,rest ,@body)))))
(caaar args)
(cadaar args)
(cdar args)
(cdr args))
(g176)))
(g176))))
(defmacro
match-letrec
args
(let ((g200 (cadddr match:expanders))
(g199 (lambda (p1 e1 p2 e2 body)
`(match-letrec
(((,p1 unquote p2) (cons ,e1 ,e2)))
,@body)))
(g195 (lambda ()
(match:syntax-err
`(match-letrec ,@args)
"syntax error in")))
(g194 (lambda (pat exp body)
`(match-letrec
((,(list->vector pat) (vector ,@exp)))
,@body)))
(g186 (lambda (pat exp body)
((cadr match:expanders)
pat
exp
body
`(match-letrec ((,pat ,exp)) ,@body)))))
(if (pair? args)
(if (list? (car args))
(if (match:andmap
(lambda (g206)
(if (and (pair? g206)
(g200 (car g206))
(pair? (cdr g206)))
(null? (cddr g206))
#f))
(car args))
(if (and (list? (cdr args)) (pair? (cdr args)))
((lambda () `(letrec ,@args)))
(let g189 ((g190 (car args)) (g188 '()) (g187 '()))
(if (null? g190)
(g195)
(if (and (pair? (car g190))
(pair? (cdar g190))
(null? (cddar g190)))
(g189 (cdr g190)
(cons (cadar g190) g188)
(cons (caar g190) g187))
(g195)))))
(if (and (pair? (car args))
(pair? (caar args))
(pair? (cdaar args))
(null? (cddaar args)))
(if (null? (cdar args))
(if (and (list? (cdr args)) (pair? (cdr args)))
(g186 (caaar args) (cadaar args) (cdr args))
(let g189 ((g190 (car args)) (g188 '()) (g187 '()))
(if (null? g190)
(g195)
(if (and (pair? (car g190))
(pair? (cdar g190))
(null? (cddar g190)))
(g189 (cdr g190)
(cons (cadar g190) g188)
(cons (caar g190) g187))
(g195)))))
(if (and (pair? (cdar args))
(pair? (cadar args))
(pair? (cdadar args))
(null? (cdr (cdadar args)))
(null? (cddar args)))
(if (and (list? (cdr args)) (pair? (cdr args)))
(g199 (caaar args)
(cadaar args)
(caadar args)
(car (cdadar args))
(cdr args))
(let g189 ((g190 (car args)) (g188 '()) (g187 '()))
(if (null? g190)
(g195)
(if (and (pair? (car g190))
(pair? (cdar g190))
(null? (cddar g190)))
(g189 (cdr g190)
(cons (cadar g190) g188)
(cons (caar g190) g187))
(g195)))))
(let g189 ((g190 (car args)) (g188 '()) (g187 '()))
(if (null? g190)
(if (and (list? (cdr args)) (pair? (cdr args)))
(g194 (reverse g187) (reverse g188) (cdr args))
(g195))
(if (and (pair? (car g190))
(pair? (cdar g190))
(null? (cddar g190)))
(g189 (cdr g190)
(cons (cadar g190) g188)
(cons (caar g190) g187))
(g195))))))
(let g189 ((g190 (car args)) (g188 '()) (g187 '()))
(if (null? g190)
(if (and (list? (cdr args)) (pair? (cdr args)))
(g194 (reverse g187) (reverse g188) (cdr args))
(g195))
(if (and (pair? (car g190))
(pair? (cdar g190))
(null? (cddar g190)))
(g189 (cdr g190)
(cons (cadar g190) g188)
(cons (caar g190) g187))
(g195))))))
(if (pair? (car args))
(if (and (pair? (caar args))
(pair? (cdaar args))
(null? (cddaar args)))
(if (null? (cdar args))
(if (and (list? (cdr args)) (pair? (cdr args)))
(g186 (caaar args) (cadaar args) (cdr args))
(let g189 ((g190 (car args)) (g188 '()) (g187 '()))
(if (null? g190)
(g195)
(if (and (pair? (car g190))
(pair? (cdar g190))
(null? (cddar g190)))
(g189 (cdr g190)
(cons (cadar g190) g188)
(cons (caar g190) g187))
(g195)))))
(if (and (pair? (cdar args))
(pair? (cadar args))
(pair? (cdadar args))
(null? (cdr (cdadar args)))
(null? (cddar args)))
(if (and (list? (cdr args)) (pair? (cdr args)))
(g199 (caaar args)
(cadaar args)
(caadar args)
(car (cdadar args))
(cdr args))
(let g189 ((g190 (car args)) (g188 '()) (g187 '()))
(if (null? g190)
(g195)
(if (and (pair? (car g190))
(pair? (cdar g190))
(null? (cddar g190)))
(g189 (cdr g190)
(cons (cadar g190) g188)
(cons (caar g190) g187))
(g195)))))
(let g189 ((g190 (car args)) (g188 '()) (g187 '()))
(if (null? g190)
(if (and (list? (cdr args)) (pair? (cdr args)))
(g194 (reverse g187) (reverse g188) (cdr args))
(g195))
(if (and (pair? (car g190))
(pair? (cdar g190))
(null? (cddar g190)))
(g189 (cdr g190)
(cons (cadar g190) g188)
(cons (caar g190) g187))
(g195))))))
(let g189 ((g190 (car args)) (g188 '()) (g187 '()))
(if (null? g190)
(if (and (list? (cdr args)) (pair? (cdr args)))
(g194 (reverse g187) (reverse g188) (cdr args))
(g195))
(if (and (pair? (car g190))
(pair? (cdar g190))
(null? (cddar g190)))
(g189 (cdr g190)
(cons (cadar g190) g188)
(cons (caar g190) g187))
(g195)))))
(g195)))
(g195))))
(defmacro
match-define
args
(let ((g210 (cadddr match:expanders))
(g209 (lambda ()
(match:syntax-err
`(match-define ,@args)
"syntax error in"))))
(if (pair? args)
(if (g210 (car args))
(if (and (pair? (cdr args)) (null? (cddr args)))
((lambda () `(begin (define ,@args))))
(g209))
(if (and (pair? (cdr args)) (null? (cddr args)))
((lambda (pat exp)
((caddr match:expanders)
pat
exp
`(match-define ,@args)))
(car args)
(cadr args))
(g209)))
(g209))))
(define match:runtime-structures #f)
(define match:set-runtime-structures
(lambda (v) (set! match:runtime-structures v)))
(define match:primitive-vector? vector?)
(defmacro
defstruct
args
(let ((field?
(lambda (x)
(if (symbol? x)
((lambda () #t))
(if (and (pair? x)
(symbol? (car x))
(pair? (cdr x))
(symbol? (cadr x))
(null? (cddr x)))
((lambda () #t))
((lambda () #f))))))
(selector-name
(lambda (x)
(if (symbol? x)
((lambda () x))
(if (and (pair? x)
(symbol? (car x))
(pair? (cdr x))
(null? (cddr x)))
((lambda (s) s) (car x))
(match:error x)))))
(mutator-name
(lambda (x)
(if (symbol? x)
((lambda () #f))
(if (and (pair? x)
(pair? (cdr x))
(symbol? (cadr x))
(null? (cddr x)))
((lambda (s) s) (cadr x))
(match:error x)))))
(filter-map-with-index
(lambda (f l)
(letrec ((mapi (lambda (l i)
(cond ((null? l) '())
((f (car l) i)
=>
(lambda (x)
(cons x (mapi (cdr l) (+ 1 i)))))
(else (mapi (cdr l) (+ 1 i)))))))
(mapi l 1)))))
(let ((g227 (lambda ()
(match:syntax-err
`(defstruct ,@args)
"syntax error in"))))
(if (and (pair? args)
(symbol? (car args))
(pair? (cdr args))
(symbol? (cadr args))
(pair? (cddr args))
(symbol? (caddr args))
(list? (cdddr args)))
(let g229 ((g230 (cdddr args)) (g228 '()))
(if (null? g230)
((lambda (name constructor predicate fields)
(let* ((selectors (map selector-name fields))
(mutators (map mutator-name fields))
(tag (if match:runtime-structures
(gentemp)
`',(match:make-structure-tag name)))
(vectorp
(cond ((eq? match:structure-control 'disjoint)
'match:primitive-vector?)
((eq? match:structure-control 'vector)
'vector?))))
(cond ((eq? match:structure-control 'disjoint)
(if (eq? vector? match:primitive-vector?)
(set! vector?
(lambda (v)
(and (match:primitive-vector? v)
(or (zero? (vector-length v))
(not (symbol? (vector-ref v 0)))
(not (match:structure?
(vector-ref v 0))))))))
(if (not (memq predicate match:disjoint-predicates))
(set! match:disjoint-predicates
(cons predicate match:disjoint-predicates))))
((eq? match:structure-control 'vector)
(if (not (memq predicate match:vector-structures))
(set! match:vector-structures
(cons predicate match:vector-structures))))
(else
(match:syntax-err
'(vector disjoint)
"invalid value for match:structure-control, legal values are")))
`(begin
,@(if match:runtime-structures
`((define ,tag (match:make-structure-tag ',name)))
'())
(define ,constructor
(lambda ,selectors (vector ,tag ,@selectors)))
(define ,predicate
(lambda (obj)
(and (,vectorp obj)
(= (vector-length obj) ,(+ 1 (length selectors)))
(eq? (vector-ref obj 0) ,tag))))
,@(filter-map-with-index
(lambda (n i)
`(define ,n (lambda (obj) (vector-ref obj ,i))))
selectors)
,@(filter-map-with-index
(lambda (n i)
(and n
`(define ,n
(lambda (obj newval)
(vector-set! obj ,i newval)))))
mutators))))
(car args)
(cadr args)
(caddr args)
(reverse g228))
(if (field? (car g230))
(g229 (cdr g230) (cons (car g230) g228))
(g227))))
(g227)))))
(defmacro
define-structure
args
(let ((g242 (lambda ()
(match:syntax-err
`(define-structure ,@args)
"syntax error in"))))
(if (and (pair? args)
(pair? (car args))
(list? (cdar args)))
(if (null? (cdr args))
((lambda (name id1)
`(define-structure (,name ,@id1) ()))
(caar args)
(cdar args))
(if (and (pair? (cdr args)) (list? (cadr args)))
(let g239 ((g240 (cadr args)) (g238 '()) (g237 '()))
(if (null? g240)
(if (null? (cddr args))
((lambda (name id1 id2 val)
(let ((mk-id (lambda (id)
(if (and (pair? id)
(equal? (car id) '@)
(pair? (cdr id))
(symbol? (cadr id))
(null? (cddr id)))
((lambda (x) x) (cadr id))
((lambda () `(! ,id)))))))
`(define-const-structure
(,name ,@(map mk-id id1))
,(map (lambda (id v) `(,(mk-id id) ,v)) id2 val))))
(caar args)
(cdar args)
(reverse g237)
(reverse g238))
(g242))
(if (and (pair? (car g240))
(pair? (cdar g240))
(null? (cddar g240)))
(g239 (cdr g240)
(cons (cadar g240) g238)
(cons (caar g240) g237))
(g242))))
(g242)))
(g242))))
(defmacro
define-const-structure
args
(let ((field?
(lambda (id)
(if (symbol? id)
((lambda () #t))
(if (and (pair? id)
(equal? (car id) '!)
(pair? (cdr id))
(symbol? (cadr id))
(null? (cddr id)))
((lambda () #t))
((lambda () #f))))))
(field-name
(lambda (x) (if (symbol? x) x (cadr x))))
(has-mutator? (lambda (x) (not (symbol? x))))
(filter-map-with-index
(lambda (f l)
(letrec ((mapi (lambda (l i)
(cond ((null? l) '())
((f (car l) i)
=>
(lambda (x)
(cons x (mapi (cdr l) (+ 1 i)))))
(else (mapi (cdr l) (+ 1 i)))))))
(mapi l 1))))
(symbol-append
(lambda l
(string->symbol
(apply string-append
(map (lambda (x)
(cond ((symbol? x) (symbol->string x))
((number? x) (number->string x))
(else x)))
l))))))
(let ((g266 (lambda ()
(match:syntax-err
`(define-const-structure ,@args)
"syntax error in"))))
(if (and (pair? args)
(pair? (car args))
(list? (cdar args)))
(if (null? (cdr args))
((lambda (name id1)
`(define-const-structure (,name ,@id1) ()))
(caar args)
(cdar args))
(if (symbol? (caar args))
(let g259 ((g260 (cdar args)) (g258 '()))
(if (null? g260)
(if (and (pair? (cdr args)) (list? (cadr args)))
(let g263 ((g264 (cadr args)) (g262 '()) (g261 '()))
(if (null? g264)
(if (null? (cddr args))
((lambda (name id1 id2 val)
(let* ((id1id2 (append id1 id2))
(raw-constructor
(symbol-append 'make-raw- name))
(constructor (symbol-append 'make- name))
(predicate (symbol-append name '?)))
`(begin
(defstruct
,name
,raw-constructor
,predicate
,@(filter-map-with-index
(lambda (arg i)
(if (has-mutator? arg)
`(,(symbol-append name '- i)
,(symbol-append
'set-
name
'-
i
'!))
(symbol-append name '- i)))
id1id2))
,(let* ((make-fresh
(lambda (x)
(if (eq? '_ x) (gentemp) x)))
(names1
(map make-fresh
(map field-name id1)))
(names2
(map make-fresh
(map field-name id2))))
`(define ,constructor
(lambda ,names1
(let* ,(map list names2 val)
(,raw-constructor
,@names1
,@names2)))))
,@(filter-map-with-index
(lambda (field i)
(if (eq? (field-name field) '_)
#f
`(define (unquote
(symbol-append
name
'-
(field-name field)))
,(symbol-append name '- i))))
id1id2)
,@(filter-map-with-index
(lambda (field i)
(if (or (eq? (field-name field) '_)
(not (has-mutator? field)))
#f
`(define (unquote
(symbol-append
'set-
name
'-
(field-name field)
'!))
,(symbol-append
'set-
name
'-
i
'!))))
id1id2))))
(caar args)
(reverse g258)
(reverse g261)
(reverse g262))
(g266))
(if (and (pair? (car g264))
(field? (caar g264))
(pair? (cdar g264))
(null? (cddar g264)))
(g263 (cdr g264)
(cons (cadar g264) g262)
(cons (caar g264) g261))
(g266))))
(g266))
(if (field? (car g260))
(g259 (cdr g260) (cons (car g260) g258))
(g266))))
(g266)))
(g266)))))
(define home-directory
(or (getenv "HOME")
(error "environment variable HOME is not defined")))
(defmacro recur args `(let ,@args))
(defmacro
rec
args
(match args
(((? symbol? x) v) `(letrec ((,x ,v)) ,x))))
(defmacro
parameterize
args
(match args ((bindings exp ...) `(begin ,@exp))))
(define gensym gentemp)
(define expand-once macroexpand-1)
(defmacro check-increment-counter args #f)
(define symbol-append
(lambda l
(string->symbol
(apply string-append
(map (lambda (x) (format #f "~a" x)) l)))))
(define gensym gentemp)
(define andmap
(lambda (f . lists)
(cond ((null? (car lists)) (and))
((null? (cdr (car lists)))
(apply f (map car lists)))
(else
(and (apply f (map car lists))
(apply andmap f (map cdr lists)))))))
(define true-object? (lambda (x) (eq? #t x)))
(define false-object? (lambda (x) (eq? #f x)))
(define void (lambda () (cond (#f #f))))
(defmacro
when
args
(match args
((tst body __1)
`(if ,tst (begin ,@body (void)) (void)))))
(defmacro
unless
args
(match args
((tst body __1)
`(if ,tst (void) (begin ,@body (void))))))
(define should-never-reach
(lambda (form)
(slib:error "fell off end of " form)))
(define make-cvector make-vector)
(define cvector vector)
(define cvector-length vector-length)
(define cvector-ref vector-ref)
(define cvector->list vector->list)
(define list->cvector list->vector)
(define-const-structure (record _))
(defmacro
record
args
(match args
((((? symbol? id) exp) ...)
`(make-record
(list ,@(map (lambda (i x) `(cons ',i ,x)) id exp))))
(_ (slib:error "syntax error at " `(record ,@args)))))
(defmacro
field
args
(match args
(((? symbol? id) exp)
`(match ,exp
(($ record x)
(match (assq ',id x)
(#f
(slib:error
"no field "
,id
'in
(cons 'record (map car x))))
((_ . x) x)))
(_ (slib:error "not a record: " '(field ,id _)))))
(_ (slib:error "syntax error at " `(field ,@args)))))
(define-const-structure (module _))
(defmacro
module
args
(match args
(((i ...) defs ...)
`(let ()
,@defs
(make-module
(record ,@(map (lambda (x) (list x x)) i)))))
(_ (slib:error "syntax error at " `(module ,@args)))))
(defmacro
import
args
(match args
((((mod defs ...) ...) body __1)
(let* ((m (map (lambda (_) (gentemp)) mod))
(newdefs
(let loop ((mod-names m) (l-defs defs))
(if (null? mod-names)
'()
(append
(let ((m (car mod-names)))
(map (match-lambda
((? symbol? x) `(,x (field ,x ,m)))
(((? symbol? i) (? symbol? e))
`(,i (field ,e ,m)))
(x (slib:error "ill-formed definition: " x)))
(car l-defs)))
(loop (cdr mod-names) (cdr l-defs)))))))
`(let (unquote
(map (lambda (m mod)
`(,m (match ,mod (($ module x) x))))
m
mod))
(let ,newdefs body ...))))))
(define raise
(lambda vals
(slib:error "Unhandled exception " vals)))
(defmacro
fluid-let
args
(match args
((((x val) ...) body __1)
(let ((old-x (map (lambda (_) (gentemp)) x))
(swap-x (map (lambda (_) (gentemp)) x))
(swap (gentemp)))
`(let ,(map list old-x val)
(let ((,swap
(lambda ()
(let ,(map list swap-x old-x)
,@(map (lambda (old x) `(set! ,old ,x)) old-x x)
,@(map (lambda (x swap) `(set! ,x ,swap))
x
swap-x)))))
(dynamic-wind ,swap (lambda () ,@body) ,swap)))))
(_ (slib:error
"syntax error at "
`(fluid-let ,@args)))))
(defmacro
handle
args
(match args
((e h)
(let ((k (gentemp)) (exn (gentemp)))
`((call-with-current-continuation
(lambda (k)
(fluid-let
((raise (lambda ,exn (k (lambda () (apply ,h ,exn))))))
(let ((v ,e)) (lambda () v))))))))
(_ (slib:error "syntax error in " `(handle ,@args)))))
(defmacro
:
args
(match args ((typeexp exp) exp)))
(defmacro
module:
args
(match args
((((i type) ...) defs ...)
`(let ()
,@defs
(make-module
(record
,@(map (lambda (i type) `(,i (: ,type ,i))) i type)))))))
(defmacro
define:
args
(match args
((name type exp) `(define ,name (: ,type ,exp)))))
(define st:failure
(lambda (chk fmt . args)
(slib:error
(apply format
#f
(string-append "~a : " fmt)
chk
args))))
(defmacro
check-bound
args
(match args
((var) var)
(x (st:failure `(check-bound ,@x) "syntax-error"))))
(defmacro
clash
args
(match args
((name info ...) name)
(x (st:failure `(clash ,@x) "syntax error"))))
(defmacro
check-lambda
args
(match args
(((id info ...) (? symbol? args) body __1)
`(lambda ,args
(check-increment-counter ,id)
,@body))
(((id info ...) args body __1)
(let* ((n 0)
(chk (let loop ((a args) (nargs 0))
(cond ((pair? a) (loop (cdr a) (+ 1 nargs)))
((null? a)
(set! n nargs)
`(= ,nargs (length args)))
(else
(set! n nargs)
`(<= ,nargs (length args))))))
(incr (if (number? id)
`(check-increment-counter ,id)
#f)))
`(let ((lam (lambda ,args ,@body)))
(lambda args
,incr
(if ,chk
(apply lam args)
,(if (eq? '= (car chk))
`(st:failure
'(check-lambda ,id ,@info)
"requires ~a arguments, passed: ~a"
,n
args)
`(st:failure
'(check-lambda ,id ,@info)
"requires >= ~a arguments, passed: ~a"
,n
args)))))))
(x (st:failure `(check-lambda ,@x) "syntax error"))))
(defmacro
check-ap
args
(match args
(((id info ...) (? symbol? f) args ...)
`(begin
(check-increment-counter ,id)
(if (procedure? ,f)
(,f ,@args)
(st:failure
'(check-ap ,id ,@info)
"not a procedure: ~a"
,f))))
(((id info ...) f args ...)
`((lambda (proc . args)
(check-increment-counter ,id)
(if (procedure? proc)
(apply proc args)
(st:failure
'(check-ap ,id ,@info)
"not a procedure: ~a"
proc)))
,f
,@args))
(x (st:failure `(check-ap ,@x) "syntax error"))))
(defmacro
check-field
args
(match args
(((id info ...) (? symbol? f) exp)
`(match ,exp
(($ record x)
(match (assq ',f x)
(#f
(st:failure
'(check-field ,id ,@info)
"no ~a field in (record ~a)"
',f
(map car x)))
((_ . x) x)))
(v (st:failure
'(check-field ,id ,@info)
"not a record: ~a"
v))))
(x (st:failure `(check-field ,@x) "syntax error"))))
(defmacro
check-match
args
(match args
(((id info ...) exp (and clause (pat _ __1)) ...)
(letrec ((last (lambda (pl)
(if (null? (cdr pl)) (car pl) (last (cdr pl))))))
(if (match (last pat)
((? symbol?) #t)
(('and subp ...) (andmap symbol? subp))
(_ #f))
`(begin
(check-increment-counter ,id)
(match ,exp ,@clause))
`(begin
(check-increment-counter ,id)
(match ,exp
,@clause
(x (st:failure
'(check-match ,id ,@info)
"no matching clause for ~a"
x)))))))
(x (st:failure `(check-match ,@x) "syntax error"))))
(defmacro
check-:
args
(match args
(((id info ...) typeexp exp)
`(st:failure
'(check-: ,id ,@info)
"static type annotation reached"))
(x (st:failure `(check-: ,@x) "syntax error"))))
(defmacro
make-check-typed
args
(match args
((prim)
(let ((chkprim (symbol-append 'check- prim)))
(list 'defmacro
chkprim
'id
(list 'quasiquote
`(lambda a
(check-increment-counter (,'unquote (car id)))
(if (null? a)
(,prim)
(st:failure
(cons ',chkprim '(,'unquote id))
"invalid arguments: ~a"
a)))))))
((prim '_)
(let ((chkprim (symbol-append 'check- prim)))
(list 'defmacro
chkprim
'id
(list 'quasiquote
`(lambda a
(check-increment-counter (,'unquote (car id)))
(if (= 1 (length a))
(,prim (car a))
(st:failure
(cons ',chkprim '(,'unquote id))
"invalid arguments: ~a"
a)))))))
((prim type1)
(let ((chkprim (symbol-append 'check- prim)))
(list 'defmacro
chkprim
'id
(list 'quasiquote
`(lambda a
(check-increment-counter (,'unquote (car id)))
(if (and (= 1 (length a)) (,type1 (car a)))
(,prim (car a))
(st:failure
(cons ',chkprim '(,'unquote id))
"invalid arguments: ~a"
a)))))))
((prim '_ '_)
(let ((chkprim (symbol-append 'check- prim)))
(list 'defmacro
chkprim
'id
(list 'quasiquote
`(lambda a
(check-increment-counter (,'unquote (car id)))
(if (= 2 (length a))
(,prim (car a) (cadr a))
(st:failure
(cons ',chkprim '(,'unquote id))
"invalid arguments: ~a"
a)))))))
((prim '_ type2)
(let ((chkprim (symbol-append 'check- prim)))
(list 'defmacro
chkprim
'id
(list 'quasiquote
`(lambda a
(check-increment-counter (,'unquote (car id)))
(if (and (= 2 (length a)) (,type2 (cadr a)))
(,prim (car a) (cadr a))
(st:failure
(cons ',chkprim '(,'unquote id))
"invalid arguments: ~a"
a)))))))
((prim type1 '_)
(let ((chkprim (symbol-append 'check- prim)))
(list 'defmacro
chkprim
'id
(list 'quasiquote
`(lambda a
(check-increment-counter (,'unquote (car id)))
(if (and (= 2 (length a)) (,type1 (car a)))
(,prim (car a) (cadr a))
(st:failure
(cons ',chkprim '(,'unquote id))
"invalid arguments: ~a"
a)))))))
((prim type1 type2)
(let ((chkprim (symbol-append 'check- prim)))
(list 'defmacro
chkprim
'id
(list 'quasiquote
`(lambda a
(check-increment-counter (,'unquote (car id)))
(if (and (= 2 (length a))
(,type1 (car a))
(,type2 (cadr a)))
(,prim (car a) (cadr a))
(st:failure
(cons ',chkprim '(,'unquote id))
"invalid arguments: ~a"
a)))))))
((prim types ...)
(let ((nargs (length types))
(chkprim (symbol-append 'check- prim))
(types (map (match-lambda ('_ '(lambda (_) #t)) (x x))
types)))
(list 'defmacro
chkprim
'id
(list 'quasiquote
`(lambda a
(check-increment-counter (,'unquote (car id)))
(if (and (= ,nargs (length a))
(andmap
(lambda (f a) (f a))
(list ,@types)
a))
(apply ,prim a)
(st:failure
(cons ',chkprim '(,'unquote id))
"invalid arguments: ~a"
a)))))))))
(defmacro
make-check-selector
args
(match args
((prim pat)
(let ((chkprim (symbol-append 'check- prim)))
(list 'defmacro
chkprim
'id
(list 'quasiquote
`(lambda a
(check-increment-counter (,'unquote (car id)))
(match a
((,pat) x)
(_ (st:failure
(cons ',chkprim '(,'unquote id))
"invalid arguments: ~a"
a))))))))))
(make-check-typed number? _)
(make-check-typed null? _)
(make-check-typed char? _)
(make-check-typed symbol? _)
(make-check-typed string? _)
(make-check-typed vector? _)
(make-check-typed box? _)
(make-check-typed pair? _)
(make-check-typed procedure? _)
(make-check-typed eof-object? _)
(make-check-typed input-port? _)
(make-check-typed output-port? _)
(make-check-typed true-object? _)
(make-check-typed false-object? _)
(make-check-typed boolean? _)
(make-check-typed list? _)
(make-check-typed not _)
(make-check-typed eqv? _ _)
(make-check-typed eq? _ _)
(make-check-typed equal? _ _)
(make-check-typed cons _ _)
(make-check-selector car (x . _))
(make-check-selector cdr (_ . x))
(make-check-selector caar ((x . _) . _))
(make-check-selector cadr (_ x . _))
(make-check-selector cdar ((_ . x) . _))
(make-check-selector cddr (_ _ . x))
(make-check-selector caaar (((x . _) . _) . _))
(make-check-selector caadr (_ (x . _) . _))
(make-check-selector cadar ((_ x . _) . _))
(make-check-selector caddr (_ _ x . _))
(make-check-selector cdaar (((_ . x) . _) . _))
(make-check-selector cdadr (_ (_ . x) . _))
(make-check-selector cddar ((_ _ . x) . _))
(make-check-selector cdddr (_ _ _ . x))
(make-check-selector
caaaar
((((x . _) . _) . _) . _))
(make-check-selector
caaadr
(_ ((x . _) . _) . _))
(make-check-selector
caadar
((_ (x . _) . _) . _))
(make-check-selector caaddr (_ _ (x . _) . _))
(make-check-selector
cadaar
(((_ x . _) . _) . _))
(make-check-selector cadadr (_ (_ x . _) . _))
(make-check-selector caddar ((_ _ x . _) . _))
(make-check-selector cadddr (_ _ _ x . _))
(make-check-selector
cdaaar
((((_ . x) . _) . _) . _))
(make-check-selector
cdaadr
(_ ((_ . x) . _) . _))
(make-check-selector
cdadar
((_ (_ . x) . _) . _))
(make-check-selector cdaddr (_ _ (_ . x) . _))
(make-check-selector
cddaar
(((_ _ . x) . _) . _))
(make-check-selector cddadr (_ (_ _ . x) . _))
(make-check-selector cdddar ((_ _ _ . x) . _))
(make-check-selector cddddr (_ _ _ _ . x))
(make-check-typed set-car! pair? _)
(make-check-typed set-cdr! pair? _)
(defmacro
check-list
id
`(lambda a
(check-increment-counter ,(car id))
(apply list a)))
(make-check-typed length list?)
(defmacro
check-append
id
`(lambda a
(check-increment-counter ,(car id))
(let loop ((b a))
(match b
(() #t)
((l) #t)
(((? list?) . y) (loop y))
(_ (st:failure
(cons 'check-append ',id)
"invalid arguments: ~a"
a))))
(apply append a)))
(make-check-typed reverse list?)
(make-check-typed list-tail list? number?)
(make-check-typed list-ref list? number?)
(make-check-typed memq _ list?)
(make-check-typed memv _ list?)
(make-check-typed member _ list?)
(defmacro
check-assq
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (= 2 (length a))
(list? (cadr a))
(andmap pair? (cadr a)))
(assq (car a) (cadr a))
(st:failure
(cons 'check-assq ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-assv
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (= 2 (length a))
(list? (cadr a))
(andmap pair? (cadr a)))
(assv (car a) (cadr a))
(st:failure
(cons 'check-assv ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-assoc
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (= 2 (length a))
(list? (cadr a))
(andmap pair? (cadr a)))
(assoc (car a) (cadr a))
(st:failure
(cons 'check-assoc ',id)
"invalid arguments: ~a"
a))))
(make-check-typed symbol->string symbol?)
(make-check-typed string->symbol string?)
(make-check-typed complex? _)
(make-check-typed real? _)
(make-check-typed rational? _)
(make-check-typed integer? _)
(make-check-typed exact? number?)
(make-check-typed inexact? number?)
(defmacro
check-=
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (<= 2 (length a)) (andmap number? a))
(apply = a)
(st:failure
(cons 'check-= ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-<
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (<= 2 (length a)) (andmap number? a))
(apply < a)
(st:failure
(cons 'check-< ',id)
"invalid arguments: ~a"
a))))
(defmacro
check->
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (<= 2 (length a)) (andmap number? a))
(apply > a)
(st:failure
(cons 'check-> ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-<=
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (<= 2 (length a)) (andmap number? a))
(apply <= a)
(st:failure
(cons 'check-<= ',id)
"invalid arguments: ~a"
a))))
(defmacro
check->=
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (<= 2 (length a)) (andmap number? a))
(apply >= a)
(st:failure
(cons 'check->= ',id)
"invalid arguments: ~a"
a))))
(make-check-typed zero? number?)
(make-check-typed positive? number?)
(make-check-typed negative? number?)
(make-check-typed odd? number?)
(make-check-typed even? number?)
(defmacro
check-max
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (<= 1 (length a)) (andmap number? a))
(apply max a)
(st:failure
(cons 'check-max ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-min
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (<= 1 (length a)) (andmap number? a))
(apply min a)
(st:failure
(cons 'check-min ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-+
id
`(lambda a
(check-increment-counter ,(car id))
(if (andmap number? a)
(apply + a)
(st:failure
(cons 'check-+ ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-*
id
`(lambda a
(check-increment-counter ,(car id))
(if (andmap number? a)
(apply * a)
(st:failure
(cons 'check-* ',id)
"invalid arguments: ~a"
a))))
(defmacro
check--
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (<= 1 (length a)) (andmap number? a))
(apply - a)
(st:failure
(cons 'check-- ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-/
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (<= 1 (length a)) (andmap number? a))
(apply / a)
(st:failure
(cons 'check-/ ',id)
"invalid arguments: ~a"
a))))
(make-check-typed abs number?)
(make-check-typed quotient number? number?)
(make-check-typed remainder number? number?)
(make-check-typed modulo number? number?)
(defmacro
check-gcd
id
`(lambda a
(check-increment-counter ,(car id))
(if (andmap number? a)
(apply gcd a)
(st:failure
(cons 'check-gcd ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-lcm
id
`(lambda a
(check-increment-counter ,(car id))
(if (andmap number? a)
(apply lcm a)
(st:failure
(cons 'check-lcm ',id)
"invalid arguments: ~a"
a))))
(make-check-typed numerator number?)
(make-check-typed denominator number?)
(make-check-typed floor number?)
(make-check-typed ceiling number?)
(make-check-typed truncate number?)
(make-check-typed round number?)
(make-check-typed rationalize number? number?)
(make-check-typed exp number?)
(make-check-typed log number?)
(make-check-typed sin number?)
(make-check-typed cos number?)
(make-check-typed tan number?)
(make-check-typed asin number?)
(make-check-typed acos number?)
(defmacro
check-atan
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (andmap number? a)
(pair? a)
(>= 2 (length a)))
(apply atan a)
(st:failure
(cons 'check-atan ',id)
"invalid arguments: ~a"
a))))
(make-check-typed sqrt number?)
(make-check-typed expt number? number?)
(make-check-typed
make-rectangular
number?
number?)
(make-check-typed make-polar number? number?)
(make-check-typed real-part number?)
(make-check-typed imag-part number?)
(make-check-typed magnitude number?)
(make-check-typed angle number?)
(make-check-typed exact->inexact number?)
(make-check-typed inexact->exact number?)
(defmacro
check-number->string
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (andmap number? a)
(pair? a)
(>= 2 (length a)))
(apply number->string a)
(st:failure
(cons 'check-number->string ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-string->number
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (pair? a)
(string? (car a))
(>= 2 (length a))
(or (null? (cdr a)) (number? (cadr a))))
(apply string->number a)
(st:failure
(cons 'check-string->number ',id)
"invalid arguments: ~a"
a))))
(make-check-typed char=? char? char?)
(make-check-typed char<? char? char?)
(make-check-typed char>? char? char?)
(make-check-typed char<=? char? char?)
(make-check-typed char>=? char? char?)
(make-check-typed char-ci=? char? char?)
(make-check-typed char-ci<? char? char?)
(make-check-typed char-ci>? char? char?)
(make-check-typed char-ci<=? char? char?)
(make-check-typed char-ci>=? char? char?)
(make-check-typed char-alphabetic? char?)
(make-check-typed char-numeric? char?)
(make-check-typed char-whitespace? char?)
(make-check-typed char-upper-case? char?)
(make-check-typed char-lower-case? char?)
(make-check-typed char->integer char?)
(make-check-typed integer->char number?)
(make-check-typed char-upcase char?)
(make-check-typed char-downcase char?)
(defmacro
check-make-string
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (pair? a)
(number? (car a))
(>= 2 (length a))
(or (null? (cdr a)) (char? (cadr a))))
(apply make-string a)
(st:failure
(cons 'check-make-string ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-string
id
`(lambda a
(check-increment-counter ,(car id))
(if (andmap char? a)
(apply string a)
(st:failure
(cons 'check-string ',id)
"invalid arguments: ~a"
a))))
(make-check-typed string-length string?)
(make-check-typed string-ref string? number?)
(make-check-typed
string-set!
string?
number?
char?)
(make-check-typed string=? string? string?)
(make-check-typed string<? string? string?)
(make-check-typed string>? string? string?)
(make-check-typed string<=? string? string?)
(make-check-typed string>=? string? string?)
(make-check-typed string-ci=? string? string?)
(make-check-typed string-ci<? string? string?)
(make-check-typed string-ci>? string? string?)
(make-check-typed string-ci<=? string? string?)
(make-check-typed string-ci>=? string? string?)
(make-check-typed
substring
string?
number?
number?)
(defmacro
check-string-append
id
`(lambda a
(check-increment-counter ,(car id))
(if (andmap string? a)
(apply string-append a)
(st:failure
(cons 'check-string-append ',id)
"invalid arguments: ~a"
a))))
(make-check-typed string->list string?)
(defmacro
check-list->string
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (= 1 (length a))
(list? (car a))
(andmap char? (car a)))
(list->string (car a))
(st:failure
(cons 'check-list->string ',id)
"invalid arguments: ~a"
a))))
(make-check-typed string-copy string?)
(make-check-typed string-fill! string? char?)
(make-check-typed make-vector number? _)
(defmacro
check-vector
id
`(lambda a
(check-increment-counter ,(car id))
(apply vector a)))
(make-check-typed vector-length vector?)
(make-check-typed vector-ref vector? number?)
(make-check-typed vector-set! vector? number? _)
(make-check-typed vector->list vector?)
(make-check-typed list->vector list?)
(make-check-typed vector-fill! vector? _)
(defmacro
check-apply
id
`(lambda a
(check-increment-counter ,(car id))
(if (pair? a)
(let loop ((arg (cdr a)))
(match arg
(((? list?)) (apply apply a))
((_ . y) (loop y))
(_ (st:failure
(cons 'check-apply ',id)
"invalid arguments: ~a"
a))))
(st:failure
`(check-apply ,@id)
"invalid arguments: ~a"
a))))
(defmacro
check-map
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (<= 2 (length a))
(procedure? (car a))
(andmap list? (cdr a)))
(apply map a)
(st:failure
(cons 'check-map ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-for-each
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (<= 2 (length a))
(procedure? (car a))
(andmap list? (cdr a)))
(apply for-each a)
(st:failure
(cons 'check-for-each ',id)
"invalid arguments: ~a"
a))))
(make-check-typed force procedure?)
(defmacro
check-call-with-current-continuation
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (= 1 (length a)) (procedure? (car a)))
(call-with-current-continuation
(lambda (k)
((car a) (check-lambda (continuation) (x) (k x)))))
(st:failure
(cons 'check-call-with-current-continuation ',id)
"invalid arguments: ~a"
a))))
(make-check-typed
call-with-input-file
string?
procedure?)
(make-check-typed
call-with-output-file
string?
procedure?)
(make-check-typed input-port? _)
(make-check-typed output-port? _)
(make-check-typed current-input-port)
(make-check-typed current-output-port)
(make-check-typed
with-input-from-file
string?
procedure?)
(make-check-typed
with-output-to-file
string?
procedure?)
(make-check-typed open-input-file string?)
(make-check-typed open-output-file string?)
(make-check-typed close-input-port input-port?)
(make-check-typed close-output-port output-port?)
(defmacro
check-read
id
`(lambda a
(check-increment-counter ,(car id))
(if (or (null? a)
(and (= 1 (length a)) (input-port? (car a))))
(apply read a)
(st:failure
(cons 'check-read ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-read-char
id
`(lambda a
(check-increment-counter ,(car id))
(if (or (null? a)
(and (= 1 (length a)) (input-port? (car a))))
(apply read-char a)
(st:failure
(cons 'check-read-char ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-peek-char
id
`(lambda a
(check-increment-counter ,(car id))
(if (or (null? a)
(and (= 1 (length a)) (input-port? (car a))))
(apply peek-char a)
(st:failure
(cons 'check-peek-char ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-char-ready?
id
`(lambda a
(check-increment-counter ,(car id))
(if (or (null? a)
(and (= 1 (length a)) (input-port? (car a))))
(apply char-ready? a)
(st:failure
(cons 'check-char-ready? ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-write
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (pair? a)
(or (null? (cdr a)) (output-port? (cadr a))))
(apply write a)
(st:failure
(cons 'check-write ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-display
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (pair? a)
(or (null? (cdr a)) (output-port? (cadr a))))
(apply display a)
(st:failure
(cons 'check-display ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-newline
id
`(lambda a
(check-increment-counter ,(car id))
(if (or (null? a) (output-port? (car a)))
(apply newline a)
(st:failure
(cons 'check-newline ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-write-char
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (pair? a)
(char? (car a))
(or (null? (cdr a)) (output-port? (cadr a))))
(apply write-char a)
(st:failure
(cons 'check-write-char ',id)
"invalid arguments: ~a"
a))))
(make-check-typed load string?)
(make-check-typed transcript-on string?)
(make-check-typed transcript-off)
(defmacro
check-symbol-append
id
`(lambda a
(check-increment-counter ,(car id))
(apply symbol-append a)))
(make-check-typed box _)
(make-check-typed unbox box?)
(make-check-typed set-box! box? _)
(make-check-typed void)
(make-check-typed make-module _)
(defmacro
check-match:error
id
`(lambda a
(check-increment-counter ,(car id))
(if (pair? a)
(apply match:error a)
(st:failure
(cons 'check-match:error ',id)
"invalid arguments: ~a"
a))))
(make-check-typed should-never-reach symbol?)
(defmacro
check-make-cvector
id
`(lambda a
(check-increment-counter ,(car id))
(if (and (pair? a)
(number? (car a))
(= 2 (length a)))
(apply make-cvector a)
(st:failure
(cons 'check-make-cvector ',id)
"invalid arguments: ~a"
a))))
(defmacro
check-cvector
id
`(lambda a
(check-increment-counter ,(car id))
(apply cvector a)))
(make-check-typed cvector-length cvector?)
(make-check-typed cvector-ref cvector? number?)
(make-check-typed cvector->list cvector?)
(make-check-typed list->cvector list?)
(defmacro
check-define-const-structure
args
(let ((field?
(lambda (x)
(or (symbol? x)
(and (pair? x)
(equal? (car x) '!)
(pair? (cdr x))
(symbol? (cadr x))
(null? (cddr x))))))
(arg-name
(lambda (x) (if (symbol? x) x (cadr x))))
(with-mutator? (lambda (x) (not (symbol? x)))))
(match args
((((? symbol? name) (? field? id1) ...))
(let ((constructor (symbol-append 'make- name))
(check-constructor
(symbol-append 'check-make- name))
(predicate (symbol-append name '?))
(access
(let loop ((l id1))
(cond ((null? l) '())
((eq? '_ (arg-name (car l))) (loop (cdr l)))
(else
(cons (symbol-append name '- (arg-name (car l)))
(loop (cdr l)))))))
(assign
(let loop ((l id1))
(cond ((null? l) '())
((eq? '_ (arg-name (car l))) (loop (cdr l)))
((not (with-mutator? (car l))) (loop (cdr l)))
(else
(cons (symbol-append
'set-
name
'-
(arg-name (car l))
'!)
(loop (cdr l)))))))
(nargs (length id1)))
`(begin
(define-const-structure (,name ,@id1) ())
(defmacro
,check-constructor
id
(lambda a
(check-increment-counter (,'unquote (car id)))
(if (= ,nargs (length a))
(apply ,constructor a)
(st:failure
(cons ',check-constructor '(,'unquote id))
"invalid arguments: ~a"
a))))
(make-check-typed ,predicate _)
,@(map (lambda (a) `(make-check-typed ,a ,predicate))
access)
,@(map (lambda (a) `(make-check-typed ,a ,predicate _))
assign))))
(x (st:failure
`(check-define-const-structure ,@x)
"syntax error")))))
(if (equal? '(match 1) (macroexpand-1 '(match 1)))
(load "/home/wright/scheme/match/match-slib.scm"))
(define sprintf
(lambda args (apply format #f args)))
(define printf
(lambda args (apply format #t args)))
(define disaster
(lambda (context fmt . args)
(slib:error
(apply sprintf
(string-append "in ~a: " fmt)
context
args))))
(define use-error
(lambda (fmt . args)
(slib:error (apply sprintf fmt args))))
(define syntax-err
(lambda (context fmt . args)
(newline)
(if context (pretty-print context))
(slib:error
(apply sprintf
(string-append "in syntax: " fmt)
args))))
(define flush-output force-output)
(define print-context
(lambda (obj depth)
(pretty-print
(recur loop
((obj obj) (n 0))
(if (pair? obj)
(if (< n depth)
(cons (loop (car obj) (+ 1 n))
(loop (cdr obj) n))
'(...))
obj)))))
(define *box-tag* (gensym))
(define box (lambda (a) (cons *box-tag* a)))
(define box?
(lambda (b)
(and (pair? b) (eq? (car b) *box-tag*))))
(define unbox cdr)
(define box-1 cdr)
(define set-box! set-cdr!)
(define sort-list sort)
(define expand-once-if-macro
(lambda (e)
(and (macro? (car e)) (macroexpand-1 e))))
(define ormap
(lambda (f . lists)
(if (null? (car lists))
(or)
(or (apply f (map car lists))
(apply ormap f (map cdr lists))))))
(define call/cc call-with-current-continuation)
(define (cpu-time) 0)
(define (pretty-print x) (display x) (newline))
(define clock-granularity 1.0e-3)
(define set-vector! vector-set!)
(define set-string! string-set!)
(define maplr
(lambda (f l)
(match l
(() '())
((x . y) (let ((v (f x))) (cons v (maplr f y)))))))
(define maprl
(lambda (f l)
(match l
(() '())
((x . y) (let ((v (maprl f y))) (cons (f x) v))))))
(define foldl
(lambda (f i l)
(recur loop
((l l) (acc i))
(match l (() acc) ((x . y) (loop y (f x acc)))))))
(define foldr
(lambda (f i l)
(recur loop
((l l))
(match l (() i) ((x . y) (f x (loop y)))))))
(define filter
(lambda (p l)
(match l
(() '())
((x . y)
(if (p x) (cons x (filter p y)) (filter p y))))))
(define filter-map
(lambda (p l)
(match l
(() '())
((x . y)
(match (p x)
(#f (filter-map p y))
(x (cons x (filter-map p y))))))))
(define rac
(lambda (l)
(match l ((last) last) ((_ . rest) (rac rest)))))
(define rdc
(lambda (l)
(match l
((_) '())
((x . rest) (cons x (rdc rest))))))
(define map-with-n
(lambda (f l)
(recur loop
((l l) (n 0))
(match l
(() '())
((x . y)
(let ((v (f x n))) (cons v (loop y (+ 1 n)))))))))
(define readfile
(lambda (f)
(with-input-from-file
f
(letrec ((rf (lambda ()
(match (read)
((? eof-object?) '())
(sexp (cons sexp (rf)))))))
rf))))
(define map2
(lambda (f a b)
(match (cons a b)
((()) '())
(((ax . ay) bx . by)
(let ((v (f ax bx))) (cons v (map2 f ay by))))
(else (error 'map2 "lists differ in length")))))
(define for-each2
(lambda (f a b)
(match (cons a b)
((()) (void))
(((ax . ay) bx . by)
(f ax bx)
(for-each2 f ay by))
(else (error 'for-each2 "lists differ in length")))))
(define andmap2
(lambda (f a b)
(match (cons a b)
((()) (and))
(((ax) bx) (f ax bx))
(((ax . ay) bx . by)
(and (f ax bx) (andmap2 f ay by)))
(else (error 'andmap2 "lists differ in length")))))
(define ormap2
(lambda (f a b)
(match (cons a b)
((()) (or))
(((ax) bx) (f ax bx))
(((ax . ay) bx . by)
(or (f ax bx) (ormap2 f ay by)))
(else (error 'ormap2 "lists differ in length")))))
(define empty-set '())
(define empty-set? null?)
(define set (lambda l (list->set l)))
(define list->set
(match-lambda
(() '())
((x . y)
(if (memq x y)
(list->set y)
(cons x (list->set y))))))
(define element-of?
(lambda (x set) (and (memq x set) #t)))
(define cardinality length)
(define set<=
(lambda (a b)
(foldr (lambda (a-elt acc) (and acc (memq a-elt b) #t))
(and)
a)))
(define set-eq?
(lambda (a b)
(and (= (cardinality a) (cardinality b))
(set<= a b))))
(define union2
(lambda (a b)
(if (null? b)
a
(foldr (lambda (x b) (if (memq x b) b (cons x b)))
b
a))))
(define union (lambda l (foldr union2 '() l)))
(define setdiff2
(lambda (a b)
(if (null? b)
a
(foldr (lambda (x c) (if (memq x b) c (cons x c)))
'()
a))))
(define setdiff
(lambda l
(if (null? l)
'()
(setdiff2 (car l) (foldr union2 '() (cdr l))))))
(define intersect2
(lambda (a b)
(if (null? b)
a
(foldr (lambda (x c) (if (memq x b) (cons x c) c))
'()
a))))
(define intersect
(lambda l
(if (null? l) '() (foldl intersect2 (car l) l))))
(define-const-structure (some _))
(define-const-structure (none))
(define none (make-none))
(define some make-some)
(define-const-structure (and exps))
(define-const-structure (app exp exps))
(define-const-structure (begin exps))
(define-const-structure (const val pred))
(define-const-structure (if exp1 exp2 exp3))
(define-const-structure (lam names body))
(define-const-structure (let binds body))
(define-const-structure (let* binds body))
(define-const-structure (letr binds body))
(define-const-structure (or exps))
(define-const-structure (prim name))
(define-const-structure (delay exp))
(define-const-structure (set! (! name) exp))
(define-const-structure (var (! name)))
(define-const-structure (vlam names name body))
(define-const-structure (match exp mclauses))
(define-const-structure (record binds))
(define-const-structure (field name exp))
(define-const-structure (cast type exp))
(define-const-structure (body defs exps))
(define-const-structure (bind name exp))
(define-const-structure (mclause pat body fail))
(define-const-structure (pvar name))
(define-const-structure (pany))
(define-const-structure (pelse))
(define-const-structure (pconst name pred))
(define-const-structure (pobj name pats))
(define-const-structure (ppred name))
(define-const-structure (pand pats))
(define-const-structure (pnot pat))
(define-const-structure (define name (! exp)))
(define-const-structure
(defstruct
tag
args
make
pred
get
set
getn
setn
mutable))
(define-const-structure (datatype _))
(define-const-structure
(variant con pred arg-types))
(define-structure
(name name
ty
timestamp
occ
mutated
gdef
primitive
struct
pure
predicate
variant
selector))
(define-structure (type ty exp))
(define-const-structure (shape _ _))
(define-const-structure (check _ _))
(define parse-def
(lambda (def)
(let ((parse-name
(match-lambda
((? symbol? s)
(if (keyword? s)
(syntax-err def "invalid use of keyword ~a" s)
s))
(n (syntax-err def "invalid variable at ~a" n)))))
(match def
(('extend-syntax ((? symbol? name) . _) . _)
(printf
"Note: installing but _not_ checking (extend-syntax (~a) ...)~%"
name)
(eval def)
'())
(('extend-syntax . _)
(syntax-err def "invalid syntax"))
(('defmacro (? symbol? name) . _)
(printf
"Note: installing but _not_ checking (defmacro ~a ...)~%"
name)
(eval def)
'())
(('defmacro . _)
(syntax-err def "invalid syntax"))
(('define (? symbol? n) e)
(list (make-define (parse-name n) (parse-exp e))))
(('define (n . args) . body)
(list (make-define
(parse-name n)
(parse-exp `(lambda ,args ,@body)))))
(('define . _) (syntax-err def "at define"))
(('begin . defs)
(foldr append '() (smap parse-def defs)))
(('define-structure (n . args))
(parse-def `(define-structure (,n ,@args) ())))
(('define-structure (n . args) inits)
(let ((m-args (smap (lambda (x) `(! ,x)) args))
(m-inits
(smap (match-lambda
((x e) `((! ,x) ,e))
(_ (syntax-err
def
"invalid structure initializer")))
inits)))
(parse-def
`(define-const-structure (,n ,@m-args) ,m-inits))))
(('define-const-structure ((? symbol? n) . args))
(parse-def
`(define-const-structure (,n ,@args) ())))
(('define-const-structure
((? symbol? n) . args)
())
(letrec ((smap-with-n
(lambda (f l)
(recur loop
((l l) (n 0))
(match l
(() '())
((x . y)
(let ((v (f x n)))
(cons v (loop y (+ 1 n)))))
(_ (syntax-err l "invalid list"))))))
(parse-arg
(lambda (a index)
(match a
(('! '_)
(list none
none
(some (symbol-append
n
'-
(+ index 1)))
(some (symbol-append
'set-
n
'-
(+ index 1)
'!))
#t))
(('! a)
(let ((a (parse-name a)))
(list (some (symbol-append n '- a))
(some (symbol-append
'set-
n
'-
a
'!))
(some (symbol-append
n
'-
(+ index 1)))
(some (symbol-append
'set-
n
'-
(+ index 1)
'!))
#t)))
('_
(list none
none
(some (symbol-append
n
'-
(+ index 1)))
none
#f))
(a (let ((a (parse-name a)))
(list (some (symbol-append n '- a))
none
(some (symbol-append
n
'-
(+ index 1)))
none
#f)))))))
(let* ((arg-info (smap-with-n parse-arg args))
(get (map car arg-info))
(set (map cadr arg-info))
(getn (map caddr arg-info))
(setn (map cadddr arg-info))
(mutable
(map (lambda (x) (car (cddddr x))) arg-info)))
(list (make-defstruct
n
(cons n args)
(symbol-append 'make- n)
(symbol-append n '?)
get
set
getn
setn
mutable)))))
(('define-const-structure
((? symbol? n) . args)
inits)
(syntax-err
def
"sorry, structure initializers are not supported"))
(('datatype . d)
(let* ((parse-variant
(match-lambda
(((? symbol? con) ? list? args)
(let ((n (parse-name con)))
(make-variant
(symbol-append 'make- n)
(symbol-append n '?)
(cons con args))))
(_ (syntax-err def "invalid datatype syntax"))))
(parse-dt
(match-lambda
(((? symbol? type) . variants)
(cons (list (parse-name type))
(smap parse-variant variants)))
((((? symbol? type) ? list? targs) . variants)
(cons (cons (parse-name type)
(smap parse-name targs))
(smap parse-variant variants)))
(_ (syntax-err def "invalid datatype syntax")))))
(list (make-datatype (smap parse-dt d)))))
(((? symbol? k) . _)
(cond ((and (not (keyword? k))
(expand-once-if-macro def))
=>
parse-def)
(else (list (make-define #f (parse-exp def))))))
(_ (list (make-define #f (parse-exp def))))))))
(define keep-match #t)
(define parse-exp
(lambda (expression)
(letrec ((n-primitive (string->symbol "#primitive"))
(parse-exp
(match-lambda
(('quote (? symbol? s)) (make-const s 'symbol?))
((and m ('quote _)) (parse-exp (quote-tf m)))
((and m ('quasiquote _))
(parse-exp (quasiquote-tf m)))
((and m (? box?)) (parse-exp (quote-tf m)))
((and m (? vector?)) (parse-exp (quote-tf m)))
((and m ('cond . _)) (parse-exp (cond-tf m)))
((and m ('case . _)) (parse-exp (case-tf m)))
((and m ('do . _)) (parse-exp (do-tf m)))
((? symbol? s) (make-var (parse-name s)))
(#t (make-const #t 'true-object?))
(#f (make-const #f 'false-object?))
((? null? c) (make-const c 'null?))
((? number? c) (make-const c 'number?))
((? char? c) (make-const c 'char?))
((? string? c) (make-const c 'string?))
((': ty e1) (make-cast ty (parse-exp e1)))
((and exp ('record . bind))
(let ((bindings (smap parse-bind bind)))
(no-repeats (map bind-name bindings) exp)
(make-record bindings)))
((and exp ('field name e1))
(make-field (parse-name name) (parse-exp e1)))
((and exp ('match e clause0 . clauses))
(=> fail)
(if keep-match
(let* ((e2 (parse-exp e))
(parse-clause
(match-lambda
((p ('=> (? symbol? failsym)) . body)
(make-mclause
(parse-pat p expression)
(parse-body
`((let ((,failsym (lambda () (,failsym))))
,@body)))
failsym))
((p . body)
(make-mclause
(parse-pat p expression)
(parse-body body)
#f))
(_ (syntax-err exp "invalid match clause")))))
(make-match
e2
(smap parse-clause (cons clause0 clauses))))
(fail)))
((and exp ('lambda bind . body))
(recur loop
((b bind) (names '()))
(match b
((? symbol? n)
(let ((rest (parse-name n)))
(no-repeats (cons rest names) exp)
(make-vlam
(reverse names)
rest
(parse-body body))))
(()
(no-repeats names exp)
(make-lam (reverse names) (parse-body body)))
((n . x) (loop x (cons (parse-name n) names)))
(_ (syntax-err
exp
"invalid lambda expression")))))
(('if e1 e2 e3)
(make-if
(parse-exp e1)
(parse-exp e2)
(parse-exp e3)))
((and if-expr ('if e1 e2))
(printf "Note: one-armed if: ")
(print-context if-expr 2)
(make-if
(parse-exp e1)
(parse-exp e2)
(parse-exp '(void))))
(('delay e) (make-delay (parse-exp e)))
(('set! n e)
(make-set! (parse-name n) (parse-exp e)))
(('and . args) (make-and (smap parse-exp args)))
(('or . args) (make-or (smap parse-exp args)))
((and exp ('let (? symbol? n) bind . body))
(let* ((nb (parse-name n))
(bindings (smap parse-bind bind)))
(no-repeats (map bind-name bindings) exp)
(make-app
(make-letr
(list (make-bind
nb
(make-lam
(map bind-name bindings)
(parse-body body))))
(make-body '() (list (make-var nb))))
(map bind-exp bindings))))
((and exp ('let bind . body))
(let ((bindings (smap parse-bind bind)))
(no-repeats (map bind-name bindings) exp)
(make-let bindings (parse-body body))))
(('let* bind . body)
(make-let*
(smap parse-bind bind)
(parse-body body)))
((and exp ('letrec bind . body))
(let ((bindings (smap parse-bind bind)))
(no-repeats (map bind-name bindings) exp)
(make-letr bindings (parse-body body))))
(('begin e1 . rest)
(make-begin (smap parse-exp (cons e1 rest))))
(('define . _)
(syntax-err
expression
"invalid context for internal define"))
(('define-structure . _)
(syntax-err
expression
"invalid context for internal define-structure"))
(('define-const-structure . _)
(syntax-err
expression
"invalid context for internal define-const-structure"))
((and m (f . args))
(cond ((and (eq? f n-primitive)
(match args
(((? symbol? p)) (make-prim p))
(_ #f))))
((and (symbol? f)
(not (keyword? f))
(expand-once-if-macro m))
=>
parse-exp)
(else
(make-app (parse-exp f) (smap parse-exp args)))))
(x (syntax-err
expression
"invalid expression at ~a"
x))))
(parse-name
(match-lambda
((? symbol? s)
(when (keyword? s)
(syntax-err
expression
"invalid use of keyword ~a"
s))
s)
(n (syntax-err
expression
"invalid variable at ~a"
n))))
(parse-bind
(match-lambda
((x e) (make-bind (parse-name x) (parse-exp e)))
(b (syntax-err expression "invalid binding at ~a" b))))
(parse-body
(lambda (body)
(recur loop
((b body) (defs '()))
(match b
(((and d ('define . _)) . rest)
(loop rest (append defs (parse-def d))))
(((and d ('define-structure . _)) . rest)
(loop rest (append defs (parse-def d))))
(((and d ('define-const-structure . _)) . rest)
(loop rest (append defs (parse-def d))))
((('begin) . rest) (loop rest defs))
(((and beg ('begin ('define . _) . _)) . rest)
(loop rest (append defs (parse-def beg))))
(((and beg ('begin ('define-structure . _) . _))
.
rest)
(loop rest (append defs (parse-def beg))))
(((and beg
('begin
('define-const-structure . _)
.
_))
.
rest)
(loop rest (append defs (parse-def beg))))
((_ . _) (make-body defs (smap parse-exp b)))
(_ (syntax-err
expression
"invalid body at ~a"
b))))))
(no-repeats
(lambda (l exp)
(match l
(() #f)
((_) #f)
((x . l)
(if (memq x l)
(syntax-err exp "name ~a repeated" x)
(no-repeats l exp)))))))
(parse-exp expression))))
(define parse-pat
(lambda (pat expression)
(letrec ((parse-pat
(match-lambda
(#f (make-ppred 'false-object?))
(#t (make-ppred 'true-object?))
(() (make-ppred 'null?))
((? number? c) (make-pconst c 'number?))
((? char? c) (make-pconst c 'char?))
((? string? c) (make-pconst c 'string?))
(('quote x) (parse-quote x))
('_ (make-pany))
('else (make-pelse))
((? symbol? n) (make-pvar (parse-pname n)))
(('not . pats)
(syntax-err
expression
"not patterns are not supported"))
(('or . pats)
(syntax-err
expression
"or patterns are not supported"))
(('get! . pats)
(syntax-err
expression
"get! patterns are not supported"))
(('set! . pats)
(syntax-err
expression
"set! patterns are not supported"))
(('and . pats)
(let* ((pats (smap parse-pat pats))
(p (make-flat-pand pats))
(non-var?
(match-lambda
((? pvar?) #f)
((? pany?) #f)
(_ #t))))
(match p
(($ pand pats)
(when (< 1 (length (filter non-var? pats)))
(syntax-err
expression
"~a has conflicting subpatterns"
(ppat p))))
(_ #f))
p))
(('? (? symbol? pred) p)
(parse-pat `(and (? ,pred) ,p)))
(('? (? symbol? pred))
(if (keyword? pred)
(syntax-err
expression
"invalid use of keyword ~a"
pred)
(make-ppred pred)))
(('$ (? symbol? c) . args)
(if (memq c '(? _ $))
(syntax-err
expression
"invalid use of pattern keyword ~a"
c)
(make-pobj
(symbol-append c '?)
(smap parse-pat args))))
((? box? cb)
(make-pobj 'box? (list (parse-pat (unbox cb)))))
((x . y)
(make-pobj
'pair?
(list (parse-pat x) (parse-pat y))))
((? vector? v)
(make-pobj
'vector?
(map parse-pat (vector->list v))))
(m (syntax-err expression "invalid pattern at ~a" m))))
(parse-quote
(match-lambda
(#f (make-pobj 'false-object? '()))
(#t (make-pobj 'true-object? '()))
(() (make-pobj 'null? '()))
((? number? c) (make-pconst c 'number?))
((? char? c) (make-pconst c 'char?))
((? string? c) (make-pconst c 'string?))
((? symbol? s) (make-pconst s 'symbol?))
((? box? cb)
(make-pobj 'box? (list (parse-quote (unbox cb)))))
((x . y)
(make-pobj
'pair?
(list (parse-quote x) (parse-quote y))))
((? vector? v)
(make-pobj
'vector?
(map parse-quote (vector->list v))))
(m (syntax-err expression "invalid pattern at ~a" m))))
(parse-pname
(match-lambda
((? symbol? s)
(cond ((keyword? s)
(syntax-err
expression
"invalid use of keyword ~a"
s))
((memq s '(? _ else $ and or not set! get! ...))
(syntax-err
expression
"invalid use of pattern keyword ~a"
s))
(else s)))
(n (syntax-err
expression
"invalid pattern variable at ~a"
n)))))
(parse-pat pat))))
(define smap
(lambda (f l)
(match l
(() '())
((x . r) (let ((v (f x))) (cons v (smap f r))))
(_ (syntax-err l "invalid list")))))
(define primitive
(lambda (p)
(list (string->symbol "#primitive") p)))
(define keyword?
(lambda (s)
(or (memq s
'(=> and
begin
case
cond
do
define
delay
if
lambda
let
let*
letrec
or
quasiquote
quote
set!
unquote
unquote-splicing
define-structure
define-const-structure
record
field
:
datatype))
(and keep-match (eq? s 'match)))))
(define make-flat-pand
(lambda (pats)
(let* ((l (foldr (lambda (p plist)
(match p
(($ pand pats) (append pats plist))
(_ (cons p plist))))
'()
pats))
(concrete?
(match-lambda
((? pconst?) #t)
((? pobj?) #t)
((? ppred?) #t)
(_ #f)))
(sorted
(append
(filter concrete? l)
(filter (lambda (x) (not (concrete? x))) l))))
(match sorted ((p) p) (_ (make-pand sorted))))))
(define never-counter 0)
(define reinit-macros!
(lambda () (set! never-counter 0)))
(define cond-tf
(lambda (cond-expr)
(recur loop
((e (cdr cond-expr)))
(match e
(()
(begin
(set! never-counter (+ 1 never-counter))
`(,(primitive 'should-never-reach)
'(cond ,never-counter))))
((('else b1 . body)) `(begin ,b1 ,@body))
((('else . _) . _)
(syntax-err cond-expr "invalid cond expression"))
(((test '=> proc) . rest)
(let ((g (gensym)))
`(let ((,g ,test))
(if ,g (,proc ,g) ,(loop rest)))))
(((#t b1 . body)) `(begin ,b1 ,@body))
(((test) . rest) `(or ,test ,(loop rest)))
(((test . body) . rest)
`(if ,test (begin ,@body) ,(loop rest)))
(_ (syntax-err cond-expr "invalid cond expression"))))))
(define scheme-cond-tf
(lambda (cond-expr)
(recur loop
((e (cdr cond-expr)))
(match e
(() `(,(primitive 'void)))
((('else b1 . body)) `(begin ,b1 ,@body))
((('else . _) . _)
(syntax-err cond-expr "invalid cond expression"))
(((test '=> proc) . rest)
(let ((g (gensym)))
`(let ((,g ,test))
(if ,g (,proc ,g) ,(loop rest)))))
(((#t b1 . body)) `(begin ,b1 ,@body))
(((test) . rest) `(or ,test ,(loop rest)))
(((test . body) . rest)
`(if ,test (begin ,@body) ,(loop rest)))
(_ (syntax-err cond-expr "invalid cond expression"))))))
(define case-tf
(lambda (case-expr)
(recur loop
((e (cdr case-expr)))
(match e
((exp) `(begin ,exp (,(primitive 'void))))
((exp ('else b1 . body)) `(begin ,b1 ,@body))
((exp ('else . _) . _)
(syntax-err case-expr "invalid case expression"))
(((? symbol? exp)
((? list? test) b1 . body)
.
rest)
`(if (,(primitive 'memv) ,exp ',test)
(begin ,b1 ,@body)
,(loop (cons exp rest))))
(((? symbol? exp) (test b1 . body) . rest)
`(if (,(primitive 'memv) ,exp '(,test))
(begin ,b1 ,@body)
,(loop (cons exp rest))))
((exp . rest)
(if (not (symbol? exp))
(let ((g (gensym)))
`(let ((,g ,exp)) ,(loop (cons g rest))))
(syntax-err case-expr "invalid case expression")))
(_ (syntax-err case-expr "invalid case expression"))))))
(define conslimit 8)
(define quote-tf
(lambda (exp)
(letrec ((qloop (match-lambda
((? box? q)
`(,(primitive qbox) ,(qloop (unbox q))))
((? symbol? q) `',q)
((? null? q) q)
((? list? q)
(if (< (length q) conslimit)
`(,(primitive qcons)
,(qloop (car q))
,(qloop (cdr q)))
`(,(primitive qlist) ,@(map qloop q))))
((x . y)
`(,(primitive qcons) ,(qloop x) ,(qloop y)))
((? vector? q)
`(,(primitive qvector)
,@(map qloop (vector->list q))))
((? boolean? q) q)
((? number? q) q)
((? char? q) q)
((? string? q) q)
(q (syntax-err
exp
"invalid quote expression at ~a"
q)))))
(match exp
(('quote q) (qloop q))
((? vector? q) (qloop q))
((? box? q) (qloop q))))))
(define quasiquote-tf
(lambda (exp)
(letrec ((make-cons
(lambda (x y)
(cond ((null? y) `(,(primitive 'list) ,x))
((and (pair? y)
(equal? (car y) (primitive 'list)))
(cons (car y) (cons x (cdr y))))
(else `(,(primitive 'cons) ,x ,y)))))
(qloop (lambda (e n)
(match e
(('quasiquote e)
(make-cons 'quasiquote (qloop `(,e) (+ 1 n))))
(('unquote e)
(if (zero? n)
e
(make-cons 'unquote (qloop `(,e) (- n 1)))))
(('unquote-splicing e)
(if (zero? n)
e
(make-cons
'unquote-splicing
(qloop `(,e) (- n 1)))))
((('unquote-splicing e) . y)
(=> fail)
(if (zero? n)
(if (null? y)
e
`(,(primitive 'append) ,e ,(qloop y n)))
(fail)))
((? box? q)
`(,(primitive 'box) ,(qloop (unbox q) n)))
((? symbol? q)
(if (memq q
'(quasiquote unquote unquote-splicing))
(syntax-err
exp
"invalid use of ~a inside quasiquote"
q)
`',q))
((? null? q) q)
((x . y) (make-cons (qloop x n) (qloop y n)))
((? vector? q)
`(,(primitive 'vector)
,@(map (lambda (z) (qloop z n))
(vector->list q))))
((? boolean? q) q)
((? number? q) q)
((? char? q) q)
((? string? q) q)
(q (syntax-err
exp
"invalid quasiquote expression at ~a"
q))))))
(match exp (('quasiquote q) (qloop q 0))))))
(define do-tf
(lambda (do-expr)
(recur loop
((e (cdr do-expr)))
(match e
(((? list? vis) (e0 ? list? e1) ? list? c)
(if (andmap (match-lambda ((_ _ . _) #t) (_ #f)) vis)
(let* ((var (map car vis))
(init (map cadr vis))
(step (map cddr vis))
(step (map (lambda (v s)
(match s
(() v)
((e) e)
(_ (syntax-err
do-expr
"invalid do expression"))))
var
step)))
(let ((doloop (gensym)))
(match e1
(()
`(let ,doloop
,(map list var init)
(if (not ,e0)
(begin ,@c (,doloop ,@step) (void))
(void))))
((body0 ? list? body)
`(let ,doloop
,(map list var init)
(if ,e0
(begin ,body0 ,@body)
(begin ,@c (,doloop ,@step)))))
(_ (syntax-err
do-expr
"invalid do expression")))))
(syntax-err do-expr "invalid do expression")))
(_ (syntax-err do-expr "invalid do expression"))))))
(define empty-env '())
(define lookup
(lambda (env x)
(match (assq x env)
(#f (disaster 'lookup "no binding for ~a" x))
((_ . b) b))))
(define lookup?
(lambda (env x)
(match (assq x env) (#f #f) ((_ . b) b))))
(define bound?
(lambda (env x)
(match (assq x env) (#f #f) (_ #t))))
(define extend-env
(lambda (env x v) (cons (cons x v) env)))
(define extend-env*
(lambda (env xs vs)
(append (map2 cons xs vs) env)))
(define join-env
(lambda (env newenv) (append newenv env)))
(define populated #t)
(define pseudo #f)
(define global-error #f)
(define share #f)
(define matchst #f)
(define fullsharing #t)
(define dump-depths #f)
(define flags #t)
(define-structure
(c depth kind fsym pres args next))
(define-structure
(v depth kind name vis split inst))
(define-structure (ts type n-gen))
(define-structure (k name order args))
(define top (box 'top))
(define bot (box 'bot))
(define generic? (lambda (d) (< d 0)))
(define new-type
(lambda (s d)
(let ((t (box s)))
(vector-set!
types
d
(cons t (vector-ref types d)))
t)))
(define generate-counter
(lambda ()
(let ((n 0)) (lambda () (set! n (+ 1 n)) n))))
(define var-counter (generate-counter))
(define make-raw-tvar
(lambda (d k) (make-v d k var-counter #t #f #f)))
(define make-tvar
(lambda (d k) (new-type (make-raw-tvar d k) d)))
(define ord? (lambda (k) (eq? 'ord k)))
(define abs? (lambda (k) (eq? 'abs k)))
(define pre? (lambda (k) (eq? 'pre k)))
(define ord-depth 2)
(define depth ord-depth)
(define types (make-vector 16 '()))
(define reset-types!
(lambda ()
(set! depth ord-depth)
(set! types (make-vector 16 '()))))
(define push-level
(lambda ()
(set! depth (+ depth 1))
(when (< (vector-length types) (+ 1 depth))
(set! types
(let ((l (vector->list types)))
(list->vector
(append l (map (lambda (_) '()) l))))))))
(define pop-level
(lambda ()
(vector-set! types depth '())
(set! depth (- depth 1))))
(define v-ord (lambda () (make-tvar depth 'ord)))
(define v-abs (lambda () (make-tvar depth 'abs)))
(define v-pre (lambda () (make-tvar depth 'pre)))
(define tvar v-ord)
(define out1tvar
(lambda () (make-tvar (- depth 1) 'ord)))
(define monotvar
(lambda () (make-tvar ord-depth 'ord)))
(define pvar
(match-lambda
(($ box (and x ($ v d k _ vis _ _)))
(unless
(number? (v-name x))
(set-v-name! x ((v-name x))))
(string->symbol
(sprintf
"~a~a~a"
(match k
('ord
(if (generic? d)
(if vis "X" "x")
(if vis "Z" "z")))
('abs (if vis "A" "a"))
('pre (if vis "P" "p")))
(v-name x)
(if dump-depths (sprintf ".~a" d) ""))))))
(define make-tvar-like
(match-lambda
(($ box ($ v d k _ _ _ _)) (make-tvar d k))))
(define ind*
(lambda (t)
(match (unbox t)
((? box? u)
(let ((v (ind* u))) (set-box! t v) v))
(_ t))))
(define type-check?
(match-lambda
((abs def inexhaust once _)
(cond (((if once check-abs1? check-abs?) abs)
(if (and def (definite? def)) 'def #t))
(inexhaust 'inexhaust)
(else #f)))))
(define type-check1?
(match-lambda
((abs def inexhaust _ _)
(cond ((check-abs1? abs)
(if (and def (definite? def)) 'def #t))
(inexhaust 'inexhaust)
(else #f)))))
(define check-abs?
(lambda (vlist)
(letrec ((seen '())
(labs? (lambda (t)
(match t
(($ box ($ v _ _ _ _ _ inst))
(and inst
(not (memq t seen))
(begin
(set! seen (cons t seen))
(ormap (match-lambda ((t . _) (labs? t)))
inst))))
(($ box ($ c _ _ _ p _ n))
(or (labs? p) (labs? n)))
(($ box (? symbol?)) #t)
(($ box i) (labs? i))))))
(ormap labs? vlist))))
(define check-abs1?
(lambda (vlist)
(letrec ((labs1?
(lambda (t)
(match t
(($ box (? v?)) #f)
(($ box ($ c _ _ _ p _ n))
(or (labs1? p) (labs1? n)))
(($ box (? symbol?)) #t)
(($ box i) (labs1? i))))))
(ormap labs1? vlist))))
(define check-sources
(lambda (info)
(letrec ((seen '())
(lsrcs (lambda (t source)
(match t
(($ box ($ v _ k _ _ _ inst))
(union (if (and inst (not (memq t seen)))
(begin
(set! seen (cons t seen))
(foldr union
empty-set
(map (match-lambda
((t . s) (lsrcs t s)))
inst)))
empty-set)))
(($ box ($ c _ _ _ p _ n))
(union (lsrcs p source) (lsrcs n source)))
(($ box (? symbol?))
(if source (set source) empty-set))
(($ box i) (lsrcs i source))))))
(match-let
(((abs _ _ _ _) info))
(if (eq? #t abs)
empty-set
(foldr union
empty-set
(map (lambda (t) (lsrcs t #f)) abs)))))))
(define check-local-sources
(match-lambda ((_ _ _ _ component) component)))
(define mk-definite-prim
(match-lambda
(($ box ($ c _ _ x p a n))
(if (eq? (k-name x) '?->)
(let ((seen '()))
(recur lprim
((t (car a)))
(match t
(($ box ($ c _ _ x p a n))
(if (memq t seen)
'()
(begin
(set! seen (cons t seen))
(match (k-name x)
('noarg (cons p (lprim n)))
('arg
(let ((args (recur argloop
((a (car a)))
(match a
(($ box
($ c
_
_
_
p
_
n))
(cons p
(argloop
n)))
(($ box
($ v
_
k
_
_
_
_))
(if (ord? k)
(list a)
'()))
(($ box
(? symbol?))
'())
(($ box i)
(argloop i))))))
(cons (list p args (lprim (cadr a)))
(lprim n))))))))
(($ box ($ v _ k _ _ _ _))
(if (ord? k) (list t) '()))
(($ box (? symbol?)) '())
(($ box i) (lprim i)))))
(mk-definite-prim n)))
(($ box (? v?)) '())
(($ box (? symbol?)) '())
(($ box i) (mk-definite-prim i))))
(define mk-definite-app
(match-lambda
(($ box ($ c _ _ _ p _ _)) (list p))))
(define mk-definite-lam
(match-lambda
(($ box ($ c _ _ x p a n))
(if (eq? (k-name x) '?->)
(let ((seen '()))
(recur llam
((t (car a)))
(match t
(($ box ($ c _ _ x p a n))
(if (memq t seen)
'()
(begin
(set! seen (cons t seen))
(match (k-name x)
('noarg (cons p (llam n)))
('arg
(let ((args (list top)))
(cons (list p args (llam (cadr a)))
(llam n))))))))
(($ box ($ v _ k _ _ _ _))
(if (ord? k) (list t) '()))
(($ box (? symbol?)) '())
(($ box i) (llam i)))))
(mk-definite-lam n)))
(($ box (? v?)) '())
(($ box (? symbol?)) '())
(($ box i) (mk-definite-lam i))))
(define definite?
(lambda (def-info)
(letrec ((non-empty?
(lambda (t)
(let ((seen '()))
(recur ldef
((t t))
(match t
(($ box ($ c _ _ _ p _ n))
(or (ldef p) (ldef n)))
(($ box ($ v d k _ _ _ inst))
(if (or global-error (abs? k))
(and inst
(generic? d)
(not (memq t seen))
(begin
(set! seen (cons t seen))
(ormap (match-lambda
((t . _) (ldef t)))
inst)))
(generic? d)))
(($ box 'top) #t)
(($ box 'bot) #f)
(($ box i) (ldef i)))))))
(ok (lambda (l)
(ormap (match-lambda
((? box? t) (non-empty? t))
((p arg rest)
(and (non-empty? p)
(ormap non-empty? arg)
(ok rest))))
l))))
(not (ok def-info)))))
(define close
(lambda (t-list) (close-type t-list #f)))
(define closeall
(lambda (t) (car (close-type (list t) #t))))
(define for
(lambda (from to f)
(cond ((= from to) (f from))
((< from to)
(begin (f from) (for (+ from 1) to f)))
(else #f))))
(define close-type
(lambda (t-list all?)
(let* ((sorted (make-vector (+ depth 1) '()))
(sort (lambda (t)
(match t
(($ box ($ c d _ _ _ _ _))
(vector-set!
sorted
d
(cons t (vector-ref sorted d))))
(($ box ($ v d _ _ _ _ _))
(vector-set!
sorted
d
(cons t (vector-ref sorted d))))
(_ #f))))
(prop-d
(lambda (down)
(letrec ((pr (match-lambda
(($ box (and x ($ v d _ _ _ _ _)))
(when (< down d) (set-v-depth! x down)))
(($ box (and x ($ c d _ _ p a n)))
(when (< down d)
(set-c-depth! x down)
(pr p)
(for-each pr a)
(pr n)))
(($ box (? symbol?)) #f)
(z (pr (ind* z))))))
(match-lambda
(($ box (and x ($ c d _ _ p a n)))
(when (<= down d) (pr p) (for-each pr a) (pr n)))
(_ #f)))))
(prop-k
(lambda (t)
(let ((pk (lambda (kind)
(rec pr
(match-lambda
(($ box (and x ($ v _ k _ _ _ _)))
(when (kind< kind k) (set-v-kind! x kind)))
(($ box (and x ($ c _ k _ p a n)))
(when (kind< kind k)
(set-c-kind! x kind)
(pr p)
(unless populated (for-each pr a))
(pr n)))
(($ box (? symbol?)) #f)
(z (pr (ind* z))))))))
(match t
(($ box (and x ($ c _ k _ p a n)))
(when (not (ord? k))
(let ((prop (pk k)))
(prop p)
(unless populated (for-each prop a))
(prop n))))
(_ #f)))))
(might-be-generalized?
(match-lambda
(($ box ($ v d k _ _ _ _))
(and (<= depth d) (or populated (ord? k) all?)))
(($ box ($ c d k _ _ _ _))
(and (<= depth d) (or populated (ord? k) all?)))
(($ box (? symbol?)) #f)))
(leaves '())
(depth-of
(match-lambda
(($ box ($ v d _ _ _ _ _)) d)
(($ box ($ c d _ _ _ _ _)) d)))
(vector-grow
(lambda (v)
(let* ((n (vector-length v))
(v2 (make-vector (* n 2) '())))
(recur loop
((i 0))
(when (< i n)
(vector-set! v2 i (vector-ref v i))
(loop (+ 1 i))))
v2)))
(parents (make-vector 64 '()))
(parent-index 0)
(parents-of
(lambda (t)
(let ((d (depth-of t)))
(if (< depth d)
(vector-ref parents (- (- d depth) 1))
'()))))
(xtnd-parents!
(lambda (t parent)
(match t
(($ box (and x ($ v d _ _ _ _ _)))
(when (= d depth)
(set! parent-index (+ 1 parent-index))
(set-v-depth! x (+ depth parent-index))
(when (< (vector-length parents) parent-index)
(set! parents (vector-grow parents)))
(set! d (+ depth parent-index)))
(vector-set!
parents
(- (- d depth) 1)
(cons parent
(vector-ref parents (- (- d depth) 1)))))
(($ box (and x ($ c d _ _ _ _ _)))
(when (= d depth)
(set! parent-index (+ 1 parent-index))
(set-c-depth! x (+ depth parent-index))
(when (< (vector-length parents) parent-index)
(set! parents (vector-grow parents)))
(set! d (+ depth parent-index)))
(vector-set!
parents
(- (- d depth) 1)
(cons parent
(vector-ref parents (- (- d depth) 1))))))))
(needs-cleanup '())
(revtype
(rec revtype
(lambda (parent t)
(let ((t (ind* t)))
(cond ((not (might-be-generalized? t)) #f)
((null? (parents-of t))
(xtnd-parents! t parent)
(set! needs-cleanup (cons t needs-cleanup))
(match t
(($ box (? v?))
(set! leaves (cons t leaves)))
(($ box ($ c _ _ _ p a n))
(let ((rev (lambda (q) (revtype t q))))
(rev p)
(for-each rev a)
(rev n)))))
((not (memq parent (parents-of t)))
(xtnd-parents! t parent))
(else #f))))))
(generic-index 0)
(gen (rec gen
(lambda (t)
(let ((t (ind* t)))
(when (might-be-generalized? t)
(set! generic-index (- generic-index 1))
(let ((parents (parents-of t)))
(match t
(($ box (and x ($ v _ k _ _ _ _)))
(set-v-depth! x generic-index)
(when (and populated
(or global-error
(abs? k)
(pre? k))
(not all?))
(set-v-inst! x '())))
(($ box (? c? x))
(set-c-depth! x generic-index)))
(for-each gen parents)))))))
(cleanup
(match-lambda
(($ box (and x ($ v d _ _ _ _ _)))
(unless (< d 0) (set-v-depth! x (- depth 1))))
(($ box (and x ($ c d _ _ _ _ _)))
(unless (< d 0) (set-c-depth! x (- depth 1))))))
(gen2 (rec gen
(lambda (t)
(let ((t (ind* t)))
(when (might-be-generalized? t)
(set! generic-index (- generic-index 1))
(match t
(($ box (and x ($ v _ k _ _ _ _)))
(set-v-depth! x generic-index)
(when (and populated
(or global-error
(abs? k)
(pre? k))
(not all?))
(set-v-inst! x '())))
(($ box (and x ($ c _ _ _ p a n)))
(set-c-depth! x generic-index)
(gen p)
(for-each gen a)
(gen n))))))))
(upd (lambda (t)
(let ((d (depth-of t)))
(when (< 0 d)
(vector-set!
types
d
(cons t (vector-ref types d))))))))
(for-each sort (vector-ref types depth))
(for 0
(- depth 1)
(lambda (i)
(for-each (prop-d i) (vector-ref sorted i))))
(for-each prop-k (vector-ref types depth))
(vector-set! types depth '())
(if fullsharing
(begin
(for-each (lambda (t) (revtype t t)) t-list)
(for-each gen leaves)
(for-each cleanup needs-cleanup))
(for-each gen2 t-list))
(for 0
depth
(lambda (i) (for-each upd (vector-ref sorted i))))
(if (null? t-list)
'()
(match-let*
((n-gen (- generic-index))
((t-list n-gen)
(if (and pseudo flags (not all?))
(pseudo t-list n-gen)
(list t-list n-gen))))
(visible t-list n-gen)
(map (lambda (t) (make-ts t n-gen)) t-list))))))
(define visible-time 0)
(define visible
(lambda (t-list n-gen)
(let* ((before (cpu-time))
(valences (make-vector n-gen '()))
(namer (generate-counter))
(lvis (rec lvis
(lambda (t pos rcd)
(match t
(($ box ($ c d _ x p a n))
(when (and (generic? d)
(not (element-of?
pos
(vector-ref
valences
(- (- d) 1)))))
(let ((u (union (vector-ref
valences
(- (- d) 1))
(set pos))))
(vector-set! valences (- (- d) 1) u))
(lvis p pos rcd)
(match (k-name x)
('?->
(lvis (car a) (not pos) #f)
(lvis (cadr a) pos #f))
('record (lvis (car a) pos #t))
(_ (for-each
(lambda (x) (lvis x pos #f))
a)))
(lvis n pos rcd)))
(($ box (and x ($ v d k _ _ _ _)))
(when (and (generic? d)
(not (element-of?
pos
(vector-ref
valences
(- (- d) 1)))))
(let ((u (union (vector-ref
valences
(- (- d) 1))
(set pos))))
(vector-set! valences (- (- d) 1) u)
(set-v-name! x namer)
(cond ((abs? k) #f)
((= 2 (cardinality u))
(set-v-split! x #t)
(set-v-vis! x #t))
((eq? pos rcd) (set-v-vis! x #t))
(else (set-v-vis! x #f))))))
(($ box (? symbol?)) #f)
(($ box i) (lvis i pos rcd)))))))
(for-each (lambda (t) (lvis t #t #f)) t-list)
(set! visible-time
(+ visible-time (- (cpu-time) before))))))
(define visible?
(match-lambda
(($ box ($ v _ k _ vis _ _))
(or (pre? k) (and vis (not (abs? k)))))
(($ box 'top) #t)
(($ box 'bot) #f)
(($ box i) (visible? i))))
(define instantiate
(lambda (ts syntax)
(match ts
(($ ts t n-gen)
(let* ((absv '())
(seen (make-vector n-gen #f))
(t2 (recur linst
((t t))
(match t
(($ box (and y ($ v d k _ _ _ inst)))
(cond ((not (generic? d)) t)
((vector-ref seen (- (- d) 1)))
(else
(let ((u (make-tvar depth k)))
(vector-set! seen (- (- d) 1) u)
(when inst
(set-v-inst!
y
(cons (cons u syntax)
inst)))
(when (or (abs? k) (pre? k))
(set! absv (cons u absv)))
u))))
(($ box ($ c d _ x p a n))
(cond ((not (generic? d)) t)
((vector-ref seen (- (- d) 1)))
(else
(let ((u (new-type
'**fix**
depth)))
(vector-set! seen (- (- d) 1) u)
(set-box!
u
(make-c
depth
'ord
x
(if flags (linst p) top)
(map linst a)
(linst n)))
u))))
(($ box (? symbol?)) t)
(($ box i) (linst i))))))
(list t2 absv))))))
(define pseudo-subtype
(lambda (t-list n-gen)
(let* ((valences (make-vector n-gen '()))
(valence-of
(lambda (d) (vector-ref valences (- (- d) 1))))
(set-valence
(lambda (d v)
(vector-set! valences (- (- d) 1) v)))
(find (rec find
(lambda (t pos mutable)
(match t
(($ box ($ v d _ _ _ _ _))
(when (generic? d)
(cond (mutable
(set-valence d (set #t #f)))
((not (element-of?
pos
(valence-of d)))
(set-valence
d
(union (valence-of d)
(set pos))))
(else #f))))
(($ box ($ c d _ x p a n))
(when (generic? d)
(cond ((= 2 (cardinality (valence-of d)))
#f)
(mutable
(set-valence d (set #t #f))
(for-each2
(lambda (t m)
(find t pos mutable))
a
(k-args x))
(find n pos mutable))
((not (element-of?
pos
(valence-of d)))
(set-valence
d
(union (valence-of d)
(set pos)))
(if (eq? '?-> (k-name x))
(begin
(find (car a)
(not pos)
mutable)
(find (cadr a) pos mutable))
(for-each2
(lambda (t m)
(find t pos (or m mutable)))
a
(k-args x)))
(find n pos mutable))
(else #f))))
(($ box (? symbol?)) #f)
(($ box i) (find i pos mutable))))))
(seen (make-vector n-gen #f))
(new-generic-var
(lambda ()
(set! n-gen (+ 1 n-gen))
(box (make-raw-tvar (- n-gen) 'ord))))
(copy (rec copy
(lambda (t)
(match t
(($ box ($ v d k _ _ _ _))
(if (generic? d)
(or (vector-ref seen (- (- d) 1))
(let ((u (if (and (abs? k)
(equal?
(valence-of d)
'(#t)))
(new-generic-var)
t)))
(vector-set! seen (- (- d) 1) u)
u))
t))
(($ box ($ c d k x p a n))
(if (generic? d)
(or (vector-ref seen (- (- d) 1))
(let* ((u (box '**fix**))
(_ (vector-set!
seen
(- (- d) 1)
u))
(new-p (if (and (eq? (ind* p) top)
(equal?
(valence-of d)
'(#f)))
(new-generic-var)
(copy p)))
(new-a (map copy a))
(new-n (copy n)))
(set-box!
u
(make-c d 'ord x new-p new-a new-n))
u))
t))
(($ box (? symbol?)) t)
(($ box i) (copy i))))))
(t-list
(map (lambda (t) (find t #t #f) (copy t)) t-list)))
(list t-list n-gen))))
(set! pseudo pseudo-subtype)
(define unify
(letrec ((uni (lambda (u v)
(unless
(eq? u v)
(match (cons u v)
((($ box (and us ($ c ud uk ux up ua un)))
$
box
(and vs ($ c vd vk vx vp va vn)))
(if (eq? ux vx)
(begin
(if (< ud vd)
(begin
(set-box! v u)
(when (kind< vk uk) (set-c-kind! us vk)))
(begin
(set-box! u v)
(when (kind< uk vk) (set-c-kind! vs uk))))
(uni un vn)
(for-each2 uni ua va)
(uni up vp))
(let* ((next (tvar))
(k (if (kind< uk vk) uk vk)))
(if (< ud vd)
(begin
(when (< vd ud) (set-c-depth! us vd))
(when (kind< vk uk) (set-c-kind! us vk))
(set-box! v u))
(begin
(when (< ud vd) (set-c-depth! vs ud))
(when (kind< uk vk) (set-c-kind! vs uk))
(set-box! u v)))
(uni (new-type
(make-c depth k ux up ua next)
depth)
vn)
(uni un
(new-type
(make-c depth k vx vp va next)
depth)))))
((($ box (and x ($ v ud uk _ _ _ _)))
$
box
($ v vd vk _ _ _ _))
(set-v-depth! x (min ud vd))
(set-v-kind! x (if (kind< uk vk) uk vk))
(set-box! v u))
((($ box ($ v ud uk _ _ _ _))
$
box
(and x ($ c vd vk _ _ _ _)))
(when (< ud vd) (set-c-depth! x ud))
(when (kind< uk vk) (set-c-kind! x uk))
(set-box! u v))
((($ box (and x ($ c ud uk _ _ _ _)))
$
box
($ v vd vk _ _ _ _))
(when (< vd ud) (set-c-depth! x vd))
(when (kind< vk uk) (set-c-kind! x vk))
(set-box! v u))
((($ box ($ v _ _ _ _ _ _)) $ box (? symbol?))
(set-box! u v))
((($ box (? symbol?)) $ box ($ v _ _ _ _ _ _))
(set-box! v u))
((($ box 'bot) $ box ($ c _ _ _ p _ n))
(set-box! v u)
(uni u p)
(uni u n))
((($ box ($ c _ _ _ p _ n)) $ box 'bot)
(set-box! u v)
(uni v p)
(uni v n))
(_ (uni (ind* u) (ind* v))))))))
uni))
(define kind<
(lambda (k1 k2) (and (ord? k2) (not (ord? k1)))))
(define r+-
(lambda (flag+ flag- tail+- absent- pos env type)
(letrec ((absent+ v-ord)
(tvars '())
(fvars '())
(absv '())
(make-flag
(lambda (pos)
(cond ((not flags) top)
(pos (flag+))
(else (flag-)))))
(typevar?
(lambda (v)
(and (symbol? v)
(not (bound? env v))
(not (memq v
'(_ bool
mu
list
&list
&optional
&rest
arglist
+
not
rec
*tidy))))))
(parse-type
(lambda (t pos)
(match t
(('mu a t)
(unless
(typevar? a)
(raise 'type "invalid type syntax at ~a" t))
(when (assq a tvars)
(raise 'type "~a is defined more than once" a))
(let* ((fix (new-type '**fix** depth))
(_ (set! tvars (cons (list a fix '()) tvars)))
(t (parse-type t pos)))
(when (eq? t fix)
(raise 'type
"recursive type is not contractive"))
(set-box! fix t)
(ind* t)))
(('rec (? list? bind) t2)
(for-each
(match-lambda
((a _)
(unless
(typevar? a)
(raise 'type "invalid type syntax at ~a" t))
(when (assq a tvars)
(raise 'type
"~a is defined more than once"
a))
(set! tvars
(cons (list a (new-type '**fix** depth) '())
tvars)))
(_ (raise 'type "invalid type syntax at ~a" t)))
bind)
(for-each
(match-lambda
((a t)
(match (assq a tvars)
((_ fix _)
(let ((t (parse-type t '?)))
(when (eq? t fix)
(raise 'type
"type is not contractive"))
(set-box! fix t))))))
bind)
(parse-type t2 pos))
('bool (parse-type '(+ false true) pos))
('s-exp
(let ((v (gensym)))
(parse-type
`(mu ,v
(+ num
nil
false
true
char
sym
str
(vec ,v)
(box ,v)
(cons ,v ,v)))
pos)))
(('list t)
(let ((u (gensym)))
(parse-type `(mu ,u (+ nil (cons ,t ,u))) pos)))
(('arglist t)
(let ((u (gensym)))
(parse-type `(mu ,u (+ noarg (arg ,t ,u))) pos)))
(('+ ? list? union) (parse-union union pos))
(t (parse-union (list t) pos)))))
(parse-union
(lambda (t pos)
(letrec ((sort-cs
(lambda (cs)
(sort-list
cs
(lambda (x y) (k< (c-fsym x) (c-fsym y))))))
(link (lambda (c t)
(set-c-next! c t)
(new-type c depth))))
(recur loop
((t t) (cs '()))
(match t
(()
(foldr link
(if pos
(absent+)
(let ((v (absent-)))
(set! absv (cons v absv))
v))
(sort-cs cs)))
(((? box? t)) (foldr link t (sort-cs cs)))
(('_) (foldr link (tail+-) (sort-cs cs)))
(((? symbol? a))
(=> fail)
(unless (typevar? a) (fail))
(let* ((cs (sort-cs cs))
(ks (map c-fsym cs)))
(foldr link
(match (assq a tvars)
((_ f aks)
(unless
(equal? ks aks)
(raise 'type
"variable ~a is not tidy"
a))
f)
(#f
(let ((v (tail+-)))
(set! tvars
(cons (list a v ks)
tvars))
v)))
cs)))
((k . rest)
(loop rest (cons (parse-k k pos) cs))))))))
(parse-k
(lambda (k pos)
(cond ((and (list? k)
(let ((n (length k)))
(and (<= 2 n) (eq? '-> (list-ref k (- n 2))))))
(let* ((rk (reverse k))
(arg (reverse (cddr rk)))
(res (car rk)))
(letrec ((mkargs
(match-lambda
(() 'noarg)
((('&rest x)) x)
((('&list x))
(let ((u (gensym)))
`(mu ,u (+ noarg (arg ,x ,u)))))
((('&optional x))
`(+ noarg (arg ,x noarg)))
((x . y) `(arg ,x ,(mkargs y)))
(_ (raise 'type
"invalid type syntax")))))
(make-c
depth
'ord
(lookup env '?->)
(make-flag pos)
(let ((a (parse-type (mkargs arg) (flip pos)))
(r (parse-type res pos)))
(list a r))
'**fix**))))
(else
(match k
((arg '?-> res)
(make-c
depth
'ord
(lookup env '?->)
(make-flag pos)
(let ((a (parse-type arg (flip pos)))
(r (parse-type res pos)))
(list a r))
'**fix**))
(('record ? list? fields)
(make-c
depth
'ord
(lookup env 'record)
(make-flag pos)
(list (recur loop
((fields fields))
(match fields
(() (if pos bot (v-ord)))
((((? symbol? f) ftype)
.
rest)
(new-type
(make-c
depth
'ord
(new-field! f)
(if pos
(v-ord)
(let ((v (v-pre)))
(set! absv
(cons v absv))
v))
(list (parse-type
ftype
pos))
(loop rest))
depth)))))
'**fix**))
(('not (? k? k))
(make-c
depth
'ord
k
(if pos
(absent+)
(let ((v (absent-)))
(set! absv (cons v absv))
v))
(map (lambda (x) (tail+-)) (k-args k))
'**fix**))
(('not c)
(unless
(bound? env c)
(raise 'type "invalid type syntax at ~a" k))
(let ((k (lookup env c)))
(make-c
depth
'ord
k
(if pos
(absent+)
(let ((v (absent-)))
(set! absv (cons v absv))
v))
(map (lambda (x) (tail+-)) (k-args k))
'**fix**)))
(('*tidy c (? symbol? f))
(unless
(bound? env c)
(raise 'type "invalid type syntax at ~a" k))
(let ((k (lookup env c)))
(make-c
depth
'ord
k
(match (assq f fvars)
((_ . f) f)
(#f
(let ((v (tail+-)))
(set! fvars
(cons (cons f v) fvars))
v)))
(map (lambda (x) (parse-type '(+) pos))
(k-args k))
'**fix**)))
(((? k? k) ? list? arg)
(unless
(= (length arg) (length (k-args k)))
(raise 'type
"~a requires ~a arguments"
(k-name k)
(length (k-args k))))
(make-c
depth
'ord
k
(make-flag pos)
(smap (lambda (x) (parse-type x pos)) arg)
'**fix**))
((c ? list? arg)
(unless
(bound? env c)
(raise 'type "invalid type syntax at ~a" k))
(let ((k (lookup env c)))
(unless
(= (length arg) (length (k-args k)))
(raise 'type
"~a requires ~a arguments"
c
(length (k-args k))))
(make-c
depth
'ord
k
(make-flag pos)
(smap (lambda (x) (parse-type x pos)) arg)
'**fix**)))
(c (unless
(bound? env c)
(raise 'type
"invalid type syntax at ~a"
k))
(let ((k (lookup env c)))
(unless
(= 0 (length (k-args k)))
(raise 'type
"~a requires ~a arguments"
c
(length (k-args k))))
(make-c
depth
'ord
k
(make-flag pos)
'()
'**fix**))))))))
(flip (match-lambda ('? '?) (#t #f) (#f #t))))
(let ((t (parse-type type pos))) (list t absv)))))
(define v-top (lambda () top))
(define r+
(lambda (env t)
(car (r+- v-top v-ord v-ord v-abs #t env t))))
(define r-
(lambda (env t)
(car (r+- v-top v-ord v-ord v-abs #f env t))))
(define r++
(lambda (env t)
(car (r+- v-top v-ord v-ord v-ord #t env t))))
(define r+collect
(lambda (env t)
(r+- v-top v-ord v-ord v-abs #t env t)))
(define r-collect
(lambda (env t)
(r+- v-top v-ord v-ord v-abs #f env t)))
(define r (lambda (t) (r+ initial-type-env t)))
(define r-match
(lambda (t)
(close '())
'(pretty-print `(fixing ,(ptype t)))
(fix-pat-abs! t)
(list t (collect-abs t))))
(define collect-abs
(lambda (t)
(let ((seen '()))
(recur loop
((t t))
(match t
(($ box ($ v _ k _ _ _ _))
(if (abs? k) (set t) empty-set))
(($ box ($ c _ _ _ p a n))
(if (memq t seen)
empty-set
(begin
(set! seen (cons t seen))
(foldr union
(union (loop p) (loop n))
(map loop a)))))
(($ box (? symbol?)) empty-set)
(($ box i) (loop i)))))))
(define fix-pat-abs!
(lambda (t)
(let ((seen '()))
(recur loop
((t t))
(match t
(($ box (and x ($ v d _ _ _ _ _)))
(when (= d depth) (set-v-kind! x 'abs)))
(($ box (and c ($ c _ _ _ p a n)))
(unless
(memq t seen)
(set! seen (cons t seen))
(loop p)
(when (and matchst flags (eq? (ind* p) top))
(set-c-pres! c (v-ord)))
(for-each loop a)
(loop n)))
(($ box (? symbol?)) t)
(($ box i) (loop i)))))))
(define pat-var-bind
(lambda (t)
(let ((seen '()))
(recur loop
((t t))
(match t
(($ box ($ v d _ _ _ _ _))
(if (< d depth)
t
(match (assq t seen)
((_ . new) new)
(#f
(let* ((new (v-ord)))
(set! seen (cons (cons t new) seen))
new)))))
(($ box ($ c d k x p a n))
(match (assq t seen)
((_ . new) new)
(#f
(let* ((fix (new-type '**fix** depth))
(fixbox (box fix))
(_ (set! seen (cons (cons t fixbox) seen)))
(new-p (if flags (loop p) top))
(new-a (map2 (lambda (mutable a)
(if mutable a (loop a)))
(k-args x)
a))
(new-n (loop n)))
(if (and (eq? new-p p)
(eq? new-n n)
(andmap eq? new-a a))
(begin (set-box! fixbox t) t)
(begin
(set-box!
fix
(make-c d k x new-p new-a new-n))
fix))))))
(($ box (? symbol?)) t)
(($ box i) (loop i)))))))
(define fields '())
(define new-field!
(lambda (x)
(match (assq x fields)
(#f
(let ((k (make-k x (+ 1 (length fields)) '(#f))))
(set! fields (cons (cons x k) fields))
k))
((_ . k) k))))
(define k<
(lambda (x y) (< (k-order x) (k-order y))))
(define k-counter 0)
(define bind-tycon
(lambda (x args covers fail-thunk)
(when (memq x
'(_ bool
mu
list
&list
&optional
&rest
arglist
+
not
rec
*tidy))
(fail-thunk "invalid type constructor ~a" x))
(set! k-counter (+ 1 k-counter))
(make-k
(if covers
(symbol-append x "." (- k-counter 100))
x)
k-counter
args)))
(define initial-type-env '())
(define init-types!
(lambda ()
(set! k-counter 0)
(set! var-counter (generate-counter))
(set! initial-type-env
(foldl (lambda (l env)
(extend-env
env
(car l)
(bind-tycon
(car l)
(cdr l)
#f
(lambda x (apply disaster 'init x)))))
empty-env
initial-type-info))
(set! k-counter 100)
(reset-types!)))
(define reinit-types!
(lambda ()
(set! var-counter (generate-counter))
(set! k-counter 100)
(set! fields '())
(set-cons-mutability! #t)
(reset-types!)))
(define deftype
(lambda (tag mutability)
(set! initial-type-env
(extend-env
initial-type-env
tag
(make-k
tag
(+ 1 (length initial-type-env))
mutability)))))
(define initial-type-info
'((?-> #f #f)
(arg #f #f)
(noarg)
(num)
(nil)
(false)
(true)
(char)
(sym)
(str)
(void)
(iport)
(oport)
(eof)
(vec #t)
(box #t)
(cons #t #t)
(cvec #f)
(promise #t)
(record #f)
(module #f)))
(define cons-is-mutable #f)
(define set-cons-mutability!
(lambda (m)
(set! cons-is-mutable m)
(set-k-args!
(lookup initial-type-env 'cons)
(list m m))))
(define tidy?
(lambda (t)
(let ((seen '()))
(recur loop
((t t) (label '()))
(match t
(($ box (? v?))
(match (assq t seen)
(#f (set! seen (cons (cons t label) seen)) #t)
((_ . l2) (equal? label l2))))
(($ box ($ c _ _ x _ a n))
(match (assq t seen)
((_ . l2) (equal? label l2))
(#f
(set! seen (cons (cons t label) seen))
(and (loop n (sort-list (cons x label) k<))
(andmap (lambda (t) (loop t '())) a)))))
(($ box (? symbol?)) #t)
(($ box i) (loop i label)))))))
(define tidy
(match-lambda
(($ ts t _)
(tidy-print t print-union assemble-union #f))
(t (tidy-print t print-union assemble-union #f))))
(define ptype
(match-lambda
(($ ts t _)
(tidy-print
t
print-raw-union
assemble-raw-union
#t))
(t (tidy-print
t
print-raw-union
assemble-raw-union
#t))))
(define tidy-print
(lambda (t print assemble top)
(let* ((share (shared-unions t top))
(bindings
(map-with-n
(lambda (t n)
(list t
(box #f)
(box #f)
(symbol-append "Y" (+ 1 n))))
share))
(body (print t (print-binding bindings)))
(let-bindings
(filter-map
(match-lambda
((_ _ ($ box #f) _) #f)
((_ ($ box t) ($ box x) _) (list x t)))
bindings)))
(assemble let-bindings body))))
(define print-binding
(lambda (bindings)
(lambda (ty share-wrapper var-wrapper render)
(match (assq ty bindings)
(#f (render))
((_ box-tprint box-name nprint)
(var-wrapper
(or (unbox box-name)
(begin
(set-box! box-name nprint)
(set-box! box-tprint (share-wrapper (render)))
nprint))))))))
(define shared-unions
(lambda (t all)
(let ((seen '()))
(recur loop
((t t) (top #t))
(match t
(($ box (? v?)) #f)
(($ box ($ c _ _ _ _ a n))
(match (and top (assq t seen))
(#f
(set! seen (cons (cons t (box 1)) seen))
(for-each (lambda (x) (loop x #t)) a)
(loop n all))
((_ . b) (set-box! b (+ 1 (unbox b))))))
(($ box (? symbol?)) #f)
(($ box i) (loop i top))))
(reverse
(filter-map
(match-lambda ((_ $ box 1) #f) ((t . _) t))
seen)))))
(define print-raw-union
(lambda (t print-share)
(recur loop
((t t))
(match t
(($ box ($ v _ _ _ _ split _))
(if (and share split)
(string->symbol (sprintf "~a#" (pvar t)))
(pvar t)))
(($ box ($ c d k x p a n))
(print-share
t
(lambda (x) x)
(lambda (x) x)
(lambda ()
(let* ((name (if (abs? k)
(symbol-append '~ (k-name x))
(k-name x)))
(name (if dump-depths
(symbol-append d '! name)
name))
(pr-x `(,name ,@(maplr loop (cons p a)))))
(cons pr-x (loop n))))))
(($ box 'top) '+)
(($ box 'bot) '-)
(($ box i) (loop i))))))
(define assemble-raw-union
(lambda (bindings body)
(if (null? bindings) body `(rec ,bindings ,body))))
(define print-union
(lambda (t print-share)
(add-+ (recur loop
((t t) (tailvis (visible? (tailvar t))))
(match t
(($ box (? v?))
(if (visible? t) (list (pvar t)) '()))
(($ box ($ c _ _ x p a n))
(print-share
t
add-+
list
(lambda ()
(cond ((visible? p)
(let* ((split-flag
(and share
(match (ind* p)
(($ box
($ v
_
_
_
_
split
_))
split)
(_ #f))))
(kname (if split-flag
(string->symbol
(sprintf
"~a#~a"
(k-name x)
(pvar p)))
(k-name x))))
(cons (cond ((null? a) kname)
((eq? '?-> (k-name x))
(let ((arg (add-+ (loop (car a)
(visible?
(tailvar
(car a))))))
(res (add-+ (loop (cadr a)
(visible?
(tailvar
(cadr a)))))))
(decode-arrow
kname
(lambda ()
(if split-flag
(string->symbol
(sprintf
"->#~a"
(pvar p)))
'->))
arg
res)))
((eq? 'record (k-name x))
`(,kname
,@(loop (car a) #f)))
(else
`(,kname
,@(maplr (lambda (x)
(add-+ (loop x
(visible?
(tailvar
x)))))
a))))
(loop n tailvis))))
((not tailvis) (loop n tailvis))
(else
(cons `(not ,(k-name x))
(loop n tailvis)))))))
(($ box 'bot) '())
(($ box i) (loop i tailvis)))))))
(define assemble-union
(lambda (bindings body)
(subst-small-type
(map clean-binding bindings)
body)))
(define add-+
(match-lambda
(() 'empty)
((t) t)
(x (cons '+ x))))
(define tailvar
(lambda (t)
(match t
(($ box (? v?)) t)
(($ box ($ c _ _ _ _ _ n)) (tailvar n))
(($ box 'bot) t)
(($ box i) (tailvar i)))))
(define decode-arrow
(lambda (kname thunk-> arg res)
(let ((args (recur loop
((l arg))
(match l
('noarg '())
(('arg a b) `(,a ,@(loop b)))
(('+ ('arg a b) 'noarg . _)
`((&optional ,a) ,@(loop b)))
(('+ 'noarg ('arg a b) . _)
`((&optional ,a) ,@(loop b)))
((? symbol? z)
(if (rectypevar? z) `(,z) `((&rest ,z))))
(('+ 'noarg z) (loop z))
(('+ ('arg a b) z)
(loop `(+ (arg ,a ,b) noarg ,z)))))))
`(,@args ,(thunk->) ,res))))
(define rectypevar?
(lambda (s)
(memq (string-ref (symbol->string s) 0) '(#\Y))))
(define typevar?
(lambda (s)
(memq (string-ref (symbol->string s) 0)
'(#\X #\Z))))
(define clean-binding
(lambda (binding)
(match binding
((u ('+ 'nil ('cons a v)))
(if (and (equal? u v) (not (memq* u a)))
(list u `(list ,a))
binding))
((u ('+ ('cons a v) 'nil))
(if (and (equal? u v) (not (memq* u a)))
(list u `(list ,a))
binding))
((u ('+ 'nil ('cons a v) (? symbol? z)))
(if (and (equal? u v) (not (memq* u a)) (typevar? z))
(list u `(list* ,a ,z))
binding))
((u ('+ ('cons a v) 'nil (? symbol? z)))
(if (and (equal? u v) (not (memq* u a)) (typevar? z))
(list u `(list* ,a ,z))
binding))
((u ('+ 'noarg ('arg a v)))
(if (and (equal? u v) (not (memq* u a)))
(list u `(&list ,a))
binding))
((u ('+ ('arg a v) 'noarg))
(if (and (equal? u v) (not (memq* u a)))
(list u `(&list ,a))
binding))
(x x))))
(define memq*
(lambda (v t)
(recur loop
((t t))
(match t
((x . y) (or (loop x) (loop y)))
(_ (eq? v t))))))
(define subst-type
(lambda (new old t)
(match new
(('list elem) (subst-list elem old t))
(_ (subst* new old t)))))
(define subst-list
(lambda (elem old t)
(match t
((? symbol?) (if (eq? old t) `(list ,elem) t))
(('+ 'nil ('cons a (? symbol? b)))
(if (and (eq? b old) (equal? elem a))
`(list ,elem)
`(+ nil (cons ,(subst-list elem old a) ,b))))
(('+ ('cons a (? symbol? b)) 'nil)
(if (and (eq? b old) (equal? elem a))
`(list ,elem)
`(+ nil (cons ,(subst-list elem old a) ,b))))
((a . b)
(cons (subst-list elem old a)
(subst-list elem old b)))
(z z))))
(define subst*
(lambda (new old t)
(cond ((eq? old t) new)
((pair? t)
(cons (subst* new old (car t))
(subst* new old (cdr t))))
(else t))))
(define subst-small-type
(lambda (bindings body)
(recur loop
((bindings bindings) (newb '()) (body body))
(match bindings
(()
(let ((newb (filter
(match-lambda
((name type) (not (equal? name type))))
newb)))
(if (null? newb)
body
`(rec ,(reverse newb) ,body))))
(((and b (name type)) . rest)
(if (and (not (memq* name type)) (small-type? type))
(loop (subst-type type name rest)
(subst-type type name newb)
(subst-type type name body))
(loop rest (cons b newb) body)))))))
(define small-type?
(lambda (t)
(>= 8
(recur loop
((t t))
(match t
('+ 0)
((? symbol? s) 1)
((? number? n) 0)
((x . y) (+ (loop x) (loop y)))
(() 0))))))
(define qop
(lambda (s)
(string->symbol (string-append "# " s))))
(define qcons (qop "cons"))
(define qbox (qop "box"))
(define qlist (qop "list"))
(define qvector (qop "vector"))
(define initial-info
`((not (a -> bool))
(eqv? (a a -> bool))
(eq? (a a -> bool))
(equal? (a a -> bool))
(cons (a b -> (cons a b)) (ic))
(car ((cons a b) -> a) (s (x . _)))
(cdr ((cons b a) -> a) (s (_ . x)))
(caar ((cons (cons a b) c) -> a)
(s ((x . _) . _)))
(cadr ((cons c (cons a b)) -> a) (s (_ x . _)))
(cdar ((cons (cons b a) c) -> a)
(s ((_ . x) . _)))
(cddr ((cons c (cons b a)) -> a) (s (_ _ . x)))
(caaar ((cons (cons (cons a b) c) d) -> a)
(s (((x . _) . _) . _)))
(caadr ((cons d (cons (cons a b) c)) -> a)
(s (_ (x . _) . _)))
(cadar ((cons (cons c (cons a b)) d) -> a)
(s ((_ x . _) . _)))
(caddr ((cons d (cons c (cons a b))) -> a)
(s (_ _ x . _)))
(cdaar ((cons (cons (cons b a) c) d) -> a)
(s (((_ . x) . _) . _)))
(cdadr ((cons d (cons (cons b a) c)) -> a)
(s (_ (_ . x) . _)))
(cddar ((cons (cons c (cons b a)) d) -> a)
(s ((_ _ . x) . _)))
(cdddr ((cons d (cons c (cons b a))) -> a)
(s (_ _ _ . x)))
(caaaar
((cons (cons (cons (cons a b) c) d) e) -> a)
(s ((((x . _) . _) . _) . _)))
(caaadr
((cons e (cons (cons (cons a b) c) d)) -> a)
(s (_ ((x . _) . _) . _)))
(caadar
((cons (cons d (cons (cons a b) c)) e) -> a)
(s ((_ (x . _) . _) . _)))
(caaddr
((cons e (cons d (cons (cons a b) c))) -> a)
(s (_ _ (x . _) . _)))
(cadaar
((cons (cons (cons c (cons a b)) d) e) -> a)
(s (((_ x . _) . _) . _)))
(cadadr
((cons e (cons (cons c (cons a b)) d)) -> a)
(s (_ (_ x . _) . _)))
(caddar
((cons (cons d (cons c (cons a b))) e) -> a)
(s ((_ _ x . _) . _)))
(cadddr
((cons e (cons d (cons c (cons a b)))) -> a)
(s (_ _ _ x . _)))
(cdaaar
((cons (cons (cons (cons b a) c) d) e) -> a)
(s ((((_ . x) . _) . _) . _)))
(cdaadr
((cons e (cons (cons (cons b a) c) d)) -> a)
(s (_ ((_ . x) . _) . _)))
(cdadar
((cons (cons d (cons (cons b a) c)) e) -> a)
(s ((_ (_ . x) . _) . _)))
(cdaddr
((cons e (cons d (cons (cons b a) c))) -> a)
(s (_ _ (_ . x) . _)))
(cddaar
((cons (cons (cons c (cons b a)) d) e) -> a)
(s (((_ _ . x) . _) . _)))
(cddadr
((cons e (cons (cons c (cons b a)) d)) -> a)
(s (_ (_ _ . x) . _)))
(cdddar
((cons (cons d (cons c (cons b a))) e) -> a)
(s ((_ _ _ . x) . _)))
(cddddr
((cons e (cons d (cons c (cons b a)))) -> a)
(s (_ _ _ _ . x)))
(set-car! ((cons a b) a -> void))
(set-cdr! ((cons a b) b -> void))
(list ((&list a) -> (list a)) (ic))
(length ((list a) -> num))
(append ((&list (list a)) -> (list a)) (ic) (d))
(reverse ((list a) -> (list a)) (ic))
(list-tail ((list a) num -> (list a)) (c))
(list-ref ((list a) num -> a) (c))
(memq (a (list a) -> (+ false (cons a (list a)))))
(memv (a (list a) -> (+ false (cons a (list a)))))
(member
(a (list a) -> (+ false (cons a (list a)))))
(assq (a (list (cons a c)) -> (+ false (cons a c))))
(assv (a (list (cons a c)) -> (+ false (cons a c))))
(assoc (a (list (cons a c)) -> (+ false (cons a c))))
(symbol->string (sym -> str))
(string->symbol (str -> sym))
(complex? (a -> bool))
(real? (a -> bool))
(rational? (a -> bool))
(integer? (a -> bool))
(exact? (num -> bool))
(inexact? (num -> bool))
(= (num num (&list num) -> bool))
(< (num num (&list num) -> bool))
(> (num num (&list num) -> bool))
(<= (num num (&list num) -> bool))
(>= (num num (&list num) -> bool))
(zero? (num -> bool))
(positive? (num -> bool))
(negative? (num -> bool))
(odd? (num -> bool))
(even? (num -> bool))
(max (num (&list num) -> num))
(min (num (&list num) -> num))
(+ ((&list num) -> num))
(* ((&list num) -> num))
(- (num (&list num) -> num))
(/ (num (&list num) -> num))
(abs (num -> num))
(quotient (num num -> num))
(remainder (num num -> num))
(modulo (num num -> num))
(gcd ((&list num) -> num))
(lcm ((&list num) -> num))
(numerator (num -> num))
(denominator (num -> num))
(floor (num -> num))
(ceiling (num -> num))
(truncate (num -> num))
(round (num -> num))
(rationalize (num num -> num))
(exp (num -> num))
(log (num -> num))
(sin (num -> num))
(cos (num -> num))
(tan (num -> num))
(asin (num -> num))
(acos (num -> num))
(atan (num (&optional num) -> num))
(sqrt (num -> num))
(expt (num num -> num))
(make-rectangular (num num -> num))
(make-polar (num num -> num))
(real-part (num -> num))
(imag-part (num -> num))
(magnitude (num -> num))
(angle (num -> num))
(exact->inexact (num -> num))
(inexact->exact (num -> num))
(number->string (num (&optional num) -> str))
(string->number (str (&optional num) -> num))
(char=? (char char -> bool))
(char<? (char char -> bool))
(char>? (char char -> bool))
(char<=? (char char -> bool))
(char>=? (char char -> bool))
(char-ci=? (char char -> bool))
(char-ci<? (char char -> bool))
(char-ci>? (char char -> bool))
(char-ci<=? (char char -> bool))
(char-ci>=? (char char -> bool))
(char-alphabetic? (char -> bool))
(char-numeric? (char -> bool))
(char-whitespace? (char -> bool))
(char-upper-case? (char -> bool))
(char-lower-case? (char -> bool))
(char->integer (char -> num))
(integer->char (num -> char))
(char-upcase (char -> char))
(char-downcase (char -> char))
(make-string (num (&optional char) -> str))
(string ((&list char) -> str))
(string-length (str -> num))
(string-ref (str num -> char))
(string-set! (str num char -> void))
(string=? (str str -> bool))
(string<? (str str -> bool))
(string>? (str str -> bool))
(string<=? (str str -> bool))
(string>=? (str str -> bool))
(string-ci=? (str str -> bool))
(string-ci<? (str str -> bool))
(string-ci>? (str str -> bool))
(string-ci<=? (str str -> bool))
(string-ci>=? (str str -> bool))
(substring (str num num -> str))
(string-append ((&list str) -> str))
(string->list (str -> (list char)) (ic))
(list->string ((list char) -> str))
(string-copy (str -> str))
(string-fill! (str char -> void))
(make-vector (num a -> (vec a)) (i))
(vector ((&list a) -> (vec a)) (i))
(vector-length ((vec a) -> num))
(vector-ref ((vec a) num -> a))
(vector-set! ((vec a) num a -> void))
(vector->list ((vec a) -> (list a)) (ic))
(list->vector ((list a) -> (vec a)) (i))
(vector-fill! ((vec a) a -> void))
(apply (((&list a) -> b) (list a) -> b) (i) (d))
(map ((a -> b) (list a) -> (list b)) (i) (d))
(for-each ((a -> b) (list a) -> void) (i) (d))
(force ((promise a) -> a) (i))
(call-with-current-continuation
(((a -> b) -> a) -> a)
(i))
(call-with-input-file
(str (iport -> a) -> a)
(i))
(call-with-output-file
(str (oport -> a) -> a)
(i))
(input-port? (a -> bool))
(output-port? (a -> bool))
(current-input-port (-> iport))
(current-output-port (-> oport))
(with-input-from-file (str (-> a) -> a) (i))
(with-output-to-file (str (-> a) -> a) (i))
(open-input-file (str -> iport))
(open-output-file (str -> oport))
(close-input-port (iport -> void))
(close-output-port (oport -> void))
(read ((&optional iport)
->
(+ eof
num
nil
false
true
char
sym
str
(box (mu sexp
(+ num
nil
false
true
char
sym
str
(vec sexp)
(cons sexp sexp)
(box sexp))))
(cons sexp sexp)
(vec sexp)))
(i))
(read-char
((&optional iport) -> (+ char eof))
(i))
(peek-char
((&optional iport) -> (+ char eof))
(i))
(char-ready? ((&optional iport) -> bool) (i))
(write (a (&optional oport) -> void) (i))
(display (a (&optional oport) -> void) (i))
(newline ((&optional oport) -> void) (i))
(write-char (char (&optional oport) -> void) (i))
(load (str -> void))
(transcript-on (str -> void))
(transcript-off (-> void))
(symbol-append ((&rest a) -> sym))
(box (a -> (box a)) (i))
(unbox ((box a) -> a) (s boxx))
(set-box! ((box a) a -> void))
(void (-> void))
(make-module (a -> (module a)))
(raise ((&rest a) -> b))
(match:error (a (&rest b) -> c))
(should-never-reach (a -> b))
(make-cvector (num a -> (cvec a)))
(cvector ((&list a) -> (cvec a)))
(cvector-length ((cvec a) -> num))
(cvector-ref ((cvec a) num -> a))
(cvector->list ((cvec a) -> (list a)) (ic))
(list->cvector ((list a) -> (cvec a)))
(,qcons (a b -> (cons a b)) (ic) (n))
(,qvector ((&list a) -> (vec a)) (i) (n))
(,qbox (a -> (box a)) (i) (n))
(,qlist ((&list a) -> (list a)) (ic) (n))
(number? ((+ num x) -> bool) (p (num)))
(null? ((+ nil x) -> bool) (p (nil)))
(char? ((+ char x) -> bool) (p (char)))
(symbol? ((+ sym x) -> bool) (p (sym)))
(string? ((+ str x) -> bool) (p (str)))
(vector? ((+ (vec a) x) -> bool) (p (vec a)))
(cvector? ((+ (cvec a) x) -> bool) (p (cvec a)))
(box? ((+ (box a) x) -> bool) (p (box a)))
(pair? ((+ (cons a b) x) -> bool) (p (cons a b)))
(procedure?
((+ ((&rest a) -> b) x) -> bool)
(p (?-> a b)))
(eof-object? ((+ eof x) -> bool) (p (eof)))
(input-port? ((+ iport x) -> bool) (p (iport)))
(output-port? ((+ oport x) -> bool) (p (oport)))
(true-object? ((+ true x) -> bool) (p (true)))
(false-object? ((+ false x) -> bool) (p (false)))
(module?
((+ (module a) x) -> bool)
(p (module a)))
(boolean? ((+ true false x) -> bool) (p #t))
(list? ((mu u (+ nil (cons y u) x)) -> bool)
(p #t))))
(define initial-env '())
(define init-env!
(lambda ()
(set! initial-env
(foldr init-prim empty-env initial-info))))
(define init-prim
(lambda (l env)
(letrec ((build-selector
(match-lambda
('x (lambda (x) x))
('_ (lambda (x) (make-pany)))
('boxx
(let ((c (lookup env 'box?)))
(lambda (x) (make-pobj c (list x)))))
((x . y)
(let ((c (lookup env 'pair?))
(lx (build-selector x))
(ly (build-selector y)))
(lambda (x) (make-pobj c (list (lx x) (ly x)))))))))
(match l
((name type . attr)
(let* ((pure (cond ((assq 'i attr) #f)
((assq 'ic attr) 'cons)
(else #t)))
(def (assq 'd attr))
(check (assq 'c attr))
(nocheck (assq 'n attr))
(pred (match (assq 'p attr)
(#f #f)
((_ #t) #t)
((_ (tag . args))
(cons (lookup initial-type-env tag) args))))
(sel (match (assq 's attr)
(#f #f)
((_ s) (build-selector s))))
(env1 (extend-env
env
name
(make-name
name
(closeall (r+ initial-type-env type))
#f
0
#f
#f
(cond (nocheck 'nocheck)
(check 'check)
(def 'imprecise)
(else #t))
#f
pure
pred
#f
sel)))
(env2 (extend-env
env1
(symbol-append 'check- name)
(make-name
(symbol-append 'check- name)
(closeall (r++ initial-type-env type))
#f
0
#f
#f
#t
#f
pure
pred
#f
sel))))
env2))))))
(define defprim
(lambda (name type mode)
(handle
(r+ initial-type-env type)
(match-lambda*
(('type . args) (apply syntax-err type args))
(x (apply raise x))))
(let* ((attr (match mode
('impure '((i)))
('pure '())
('pure-if-cons-is '((ic)))
('mutates-cons
(set! cons-mutators (cons name cons-mutators))
'())
(x (use-error
"invalid attribute ~a for st:defprim"
x))))
(info `(,name ,type ,@attr)))
(unless
(equal? info (assq name initial-info))
(set! initial-info (cons info initial-info))
(set! initial-env (init-prim info initial-env))))))
(init-types!)
(init-env!)
(define %not (lookup initial-env 'not))
(define %list (lookup initial-env 'list))
(define %cons (lookup initial-env 'cons))
(define %should-never-reach
(lookup initial-env 'should-never-reach))
(define %false-object?
(lookup initial-env 'false-object?))
(define %eq? (lookup initial-env 'eq?))
(define %eqv? (lookup initial-env 'eqv?))
(define %equal? (lookup initial-env 'equal?))
(define %null? (lookup initial-env 'null?))
(define %vector? (lookup initial-env 'vector?))
(define %cvector? (lookup initial-env 'cvector?))
(define %list? (lookup initial-env 'list?))
(define %boolean? (lookup initial-env 'boolean?))
(define %procedure?
(lookup initial-env 'procedure?))
(define n-unbound 0)
(define bind-defs
(lambda (defs env0 tenv0 old-unbound timestamp)
(letrec ((cons-mutable #f)
(unbound '())
(use-var
(lambda (x env context mk-node)
(match (lookup? env x)
(#f
(let* ((b (bind-var x)) (n (mk-node b)))
(set-name-timestamp! b context)
(set! unbound (cons n unbound))
n))
(b (when (and (name-primitive b)
(memq x cons-mutators))
(set! cons-mutable #t))
(set-name-occ! b (+ 1 (name-occ b)))
(mk-node b)))))
(bind-var
(lambda (x)
(make-name
x
#f
timestamp
0
#f
#f
#f
#f
#f
#f
#f
#f)))
(bind (lambda (e env tenv context)
(let ((bind-cur (lambda (x) (bind x env tenv context))))
(match e
(($ var x) (use-var x env context make-var))
(($ prim x)
(use-var x initial-env context make-var))
(($ const c pred)
(use-var
pred
initial-env
context
(lambda (p) (make-const c p))))
(($ lam args e2)
(let* ((b-args (map bind-var args))
(newenv (extend-env* env args b-args)))
(make-lam
b-args
(bind e2 newenv tenv context))))
(($ vlam args rest e2)
(let* ((b-args (map bind-var args))
(b-rest (bind-var rest))
(newenv
(extend-env*
env
(cons rest args)
(cons b-rest b-args))))
(make-vlam
b-args
b-rest
(bind e2 newenv tenv context))))
(($ match e1 clauses)
(make-match
(bind-cur e1)
(map (lambda (x)
(bind-mclause x env tenv context))
clauses)))
(($ app e1 args)
(make-app (bind-cur e1) (map bind-cur args)))
(($ begin exps) (make-begin (map bind-cur exps)))
(($ and exps) (make-and (map bind-cur exps)))
(($ or exps) (make-or (map bind-cur exps)))
(($ if test then els)
(make-if
(bind-cur test)
(bind-cur then)
(bind-cur els)))
(($ delay e2) (make-delay (bind-cur e2)))
(($ set! x e2)
(use-var
x
env
context
(lambda (b)
(when (name-struct b)
(syntax-err
(pexpr e)
"define-structure identifier ~a may not be assigned"
x))
(when (name-primitive b)
(syntax-err
(pexpr e)
"(set! ~a ...) requires (define ~a ...)"
x
x))
(when (and (not (name-mutated b))
(not (= (name-timestamp b)
timestamp)))
(syntax-err
(pexpr e)
"(set! ~a ...) missing from compilation unit defining ~a"
x
x))
(set-name-mutated! b #t)
(make-set! b (bind-cur e2)))))
(($ let args e2)
(let* ((b-args
(map (match-lambda
(($ bind x e)
(make-bind
(bind-var x)
(bind-cur e))))
args))
(newenv
(extend-env*
env
(map bind-name args)
(map bind-name b-args))))
(make-let
b-args
(bind e2 newenv tenv context))))
(($ let* args e2)
(recur loop
((args args) (b-args '()) (env env))
(match args
((($ bind x e) . rest)
(let ((b (bind-var x)))
(loop rest
(cons (make-bind
b
(bind e
env
tenv
context))
b-args)
(extend-env env x b))))
(()
(make-let*
(reverse b-args)
(bind e2 env tenv context))))))
(($ letr args e2)
(let* ((b-args
(map (match-lambda
(($ bind x e)
(make-bind (bind-var x) e)))
args))
(newenv
(extend-env*
env
(map bind-name args)
(map bind-name b-args)))
(b-args
(map (match-lambda
(($ bind b e)
(let* ((n (name-occ b))
(e2 (bind e
newenv
tenv
context)))
(set-name-occ! b n)
(make-bind b e2))))
b-args)))
(make-letr
b-args
(bind e2 newenv tenv context))))
(($ body defs exps)
(match-let*
(((defs newenv newtenv)
(bind-defn defs env tenv #f)))
(make-body
defs
(map (lambda (x)
(bind x newenv newtenv context))
exps))))
(($ record args)
(make-record
(map (match-lambda
(($ bind x e)
(new-field! x)
(make-bind x (bind-cur e))))
args)))
(($ field x e2)
(new-field! x)
(make-field x (bind-cur e2)))
(($ cast ty e2)
(match-let
(((t absv)
(handle
(r+collect
tenv
(match ty
(('rec bind ty2)
`(rec ,bind (,ty2 -> ,ty2)))
(_ `(,ty -> ,ty))))
(match-lambda*
(('type . args)
(apply syntax-err ty args))
(x (apply raise x))))))
(make-cast
(list ty t absv)
(bind-cur e2))))))))
(bind-mclause
(lambda (clause env tenv context)
(match-let*
((($ mclause pattern body failsym) clause)
(patenv empty-env)
(bp (recur loop
((p pattern))
(match p
(($ pvar x)
(when (bound? patenv x)
(syntax-err
(ppat pattern)
"pattern variable ~a repeated"
x))
(let ((b (bind-var x)))
(set! patenv (extend-env patenv x b))
(make-pvar b)))
(($ pobj c args)
(use-var
c
env
context
(lambda (b)
(cond ((boolean? (name-predicate b))
(syntax-err
(ppat pattern)
"~a is not a predicate"
c))
((and (not (eq? b %vector?))
(not (eq? b %cvector?))
(not (= (length
(cdr (name-predicate
b)))
(length args))))
(syntax-err
(ppat pattern)
"~a requires ~a sub-patterns"
c
(length
(cdr (name-predicate
b)))))
(else
(make-pobj
b
(map loop args)))))))
(($ pand pats)
(make-pand (map loop pats)))
(($ pnot pat) (make-pnot (loop pat)))
(($ ppred pred)
(use-var
pred
env
context
(lambda (b)
(unless
(name-predicate b)
(syntax-err
(ppat pattern)
"~a is not a predicate"
pred))
(make-ppred b))))
(($ pany) p)
(($ pelse) p)
(($ pconst c pred)
(use-var
pred
initial-env
context
(lambda (p) (make-pconst c p))))))))
(if failsym
(let ((b (bind-var failsym)))
(when (bound? patenv failsym)
(syntax-err
(ppat pattern)
"fail symbol ~a repeated"
failsym))
(set! patenv (extend-env patenv failsym b))
(make-mclause
bp
(bind body (join-env env patenv) tenv context)
b))
(make-mclause
bp
(bind body (join-env env patenv) tenv context)
#f)))))
(bind-defn
(lambda (defs env tenv glob)
(let* ((newenv empty-env)
(newtenv empty-env)
(struct-def
(lambda (x pure)
(when (or (bound? newenv x)
(and glob (bound? initial-env x)))
(syntax-err
#f
"~a defined more than once"
x))
(let ((b (bind-var x)))
(set-name-primitive! b #t)
(set-name-struct! b #t)
(set-name-pure! b pure)
(set! newenv (extend-env newenv x b))
b)))
(bind1 (match-lambda
((and z ($ define x e))
(cond ((not x) z)
((bound? newenv x)
(if glob
(make-define #f (make-set! x e))
(syntax-err
#f
"~a defined more than once"
x)))
(else
(let ((b (bind-var x)))
(set-name-gdef! b glob)
(set! newenv
(extend-env newenv x b))
(make-define b e)))))
((and d
($ defstruct
tag
args
make
pred
get
set
getn
setn
mutable))
(let* ((make (struct-def
make
(map not mutable)))
(pred (struct-def pred #t))
(bind-get
(lambda (name n)
(match name
(($ some x)
(let ((b (struct-def
x
#t)))
(set-name-selector!
b
(lambda (x)
(make-pobj
pred
(map-with-n
(lambda (_ m)
(if (= m n)
x
(make-pany)))
get))))
(some b)))
(none none))))
(bind-set
(match-lambda
(($ some x)
(some (struct-def x #t)))
(none none)))
(get (map-with-n bind-get get))
(getn (map-with-n bind-get getn))
(set (map bind-set set))
(setn (map bind-set setn))
(_ (when (bound? newtenv tag)
(syntax-err
(pdef d)
"type constructor ~a defined more than once"
tag)))
(tc (bind-tycon
tag
mutable
(bound? tenv tag)
(lambda args
(apply syntax-err
(cons (pdef d)
args))))))
(set! newtenv (extend-env newtenv tag tc))
(set-name-predicate!
pred
`(,tc ,@(map (lambda (_) (gensym)) get)))
(make-defstruct
tc
args
make
pred
get
set
getn
setn
mutable)))
((and d ($ datatype dt))
(make-datatype
(maplr (match-lambda
(((tag . args) . bindings)
(when (bound? newtenv tag)
(syntax-err
(pdef d)
"type constructor ~a defined more than once"
tag))
(let ((tc (bind-tycon
tag
(map (lambda (_) #f)
args)
(bound? tenv tag)
(lambda args
(apply syntax-err
(cons (pdef d)
args))))))
(set! newtenv
(extend-env newtenv tag tc))
(cons (cons tc args)
(maplr (match-lambda
(($ variant
con
pred
arg-types)
(let ((make (struct-def
con
#t))
(pred (struct-def
pred
#t)))
(set-name-predicate!
pred
(cons tc
args))
(set-name-variant!
pred
arg-types)
(make-variant
make
pred
arg-types))))
bindings)))))
dt)))))
(defs2 (maplr bind1 defs))
(newenv2 (join-env env newenv))
(newtenv2 (join-env tenv newtenv))
(bind2 (match-lambda
((and ($ define (? name? x) ($ var y)))
(=> fail)
(if (eq? (name-name x) y)
(if (bound? initial-env y)
(make-define
x
(make-var (lookup initial-env y)))
(begin
(printf
"Warning: (define ~a ~a) but ~a is not a primitive~%"
y
y
y)
(fail)))
(fail)))
((and ($ define x e2) context)
(when (and glob
(name? x)
(bound?
initial-env
(name-name x)))
(printf
"Note: (define ~a ...) hides primitive ~a~%"
(name-name x)
(name-name x)))
(make-define
(or x
(let ((b (bind-var x)))
(set-name-gdef! b glob)
b))
(bind e2 newenv2 newtenv2 context)))
(d d))))
(list (maplr bind2 defs2) newenv2 newtenv2))))
(bind-old
(lambda (e env)
(match e
(($ var x)
(match (lookup? env (name-name x))
(#f (set! unbound (cons e unbound)))
(b (when (and (name-primitive b)
(memq x cons-mutators))
(set! cons-mutable #t))
(set-name-occ! b (+ 1 (name-occ b)))
(set-var-name! e b))))
(($ set! x _)
(match (lookup? env (name-name x))
(#f (set! unbound (cons e unbound)))
(b (when (name-struct b)
(syntax-err
(pexpr e)
"define-structure identifier ~a may not be assigned"
x))
(when (name-primitive b)
(syntax-err
(pexpr e)
"(set! ~a ...) requires (define ~a ...)"
x
x))
(when (and (not (name-mutated b))
(not (= (name-timestamp b)
timestamp)))
(syntax-err
(pexpr e)
"(set! ~a ...) missing from compilation unit defining ~a"
x
x))
(set-name-mutated! b #t)
(set-name-occ! b (+ 1 (name-occ b)))
(set-set!-name! e b))))))))
(match-let
(((defs env tenv) (bind-defn defs env0 tenv0 #t)))
(for-each
(lambda (x) (bind-old x env))
old-unbound)
(set-cons-mutability! cons-mutable)
(set! n-unbound (length unbound))
(list defs env tenv unbound)))))
(define rebind-var
(lambda (b)
(make-name
(name-name b)
(name-ty b)
(name-timestamp b)
(name-occ b)
(name-mutated b)
#f
#f
#f
#f
#f
#f
#f)))
(define warn-unbound
(lambda (l)
(let* ((names '())
(node->name
(match-lambda
(($ var x) x)
(($ set! x _) x)
(($ pobj x _) x)
(($ ppred x) x)))
(warn (lambda (b)
(unless
(memq (name-name b) names)
(set! names (cons (name-name b) names))
(printf
"Warning: ~a is unbound in "
(name-name b))
(print-context (pexpr (name-timestamp b)) 2)))))
(for-each (lambda (x) (warn (node->name x))) l))))
(define name-unbound?
(lambda (x) (not (number? (name-timestamp x)))))
(define improve-defs
(lambda (defs)
(map (match-lambda
(($ define x e2) (make-define x (improve e2)))
(x x))
defs)))
(define improve
(match-lambda
(($ match e clauses) (improve-match e clauses))
(($ if tst thn els) (improve-if tst thn els))
((? var? e) e)
((? const? e) e)
(($ lam args e2) (make-lam args (improve e2)))
(($ vlam args rest e2)
(make-vlam args rest (improve e2)))
(($ app (and e1 ($ var x)) args)
(let ((args (map improve args)))
(if (and (eq? x %list) (< (length args) conslimit))
(foldr (lambda (a rest)
(make-app (make-var %cons) (list a rest)))
(make-const '() %null?)
args)
(make-app e1 args))))
(($ app e1 args)
(make-app (improve e1) (map improve args)))
(($ begin exps) (make-begin (map improve exps)))
(($ and exps) (make-and (map improve exps)))
(($ or exps) (make-or (map improve exps)))
(($ delay e2) (make-delay (improve e2)))
(($ set! x e2) (make-set! x (improve e2)))
(($ let args e2)
(let ((args (map (match-lambda
(($ bind x e) (make-bind x (improve e))))
args)))
(make-let args (improve e2))))
(($ let* args e2)
(let ((args (map (match-lambda
(($ bind x e) (make-bind x (improve e))))
args)))
(make-let* args (improve e2))))
(($ letr args e2)
(let ((args (map (match-lambda
(($ bind x e) (make-bind x (improve e))))
args)))
(make-letr args (improve e2))))
(($ body defs exps)
(let ((defs (improve-defs defs)))
(make-body defs (map improve exps))))
(($ record args)
(make-record
(map (match-lambda
(($ bind x e) (make-bind x (improve e))))
args)))
(($ field x e2) (make-field x (improve e2)))
(($ cast ty e2) (make-cast ty (improve e2)))))
(define improve-if
(lambda (tst thn els)
(let ((if->match
(lambda (x p mk-s thn els)
(let ((else-pat
(match els
(($ app ($ var q) _)
(if (eq? q %should-never-reach)
(make-pelse)
(make-pany)))
(_ (make-pany)))))
(make-match
(make-var x)
(list (make-mclause
(mk-s (make-ppred p))
(make-body '() (list thn))
#f)
(make-mclause
(mk-s else-pat)
(make-body '() (list els))
#f)))))))
(match tst
(($ app ($ var v) (e))
(=> fail)
(if (eq? v %not) (improve-if e els thn) (fail)))
(($ app ($ var eq) (($ const #f _) val))
(=> fail)
(if (or (eq? eq %eq?)
(eq? eq %eqv?)
(eq? eq %equal?))
(improve-if val els thn)
(fail)))
(($ app ($ var eq) (val ($ const #f _)))
(=> fail)
(if (or (eq? eq %eq?)
(eq? eq %eqv?)
(eq? eq %equal?))
(improve-if val els thn)
(fail)))
(($ app ($ var v) (($ var x)))
(=> fail)
(if (and (name-predicate v) (not (name-mutated x)))
(improve (if->match x v (lambda (x) x) thn els))
(fail)))
(($ app ($ var v) (($ app ($ var s) (($ var x)))))
(=> fail)
(if (and (name-predicate v)
(name-selector s)
(not (name-mutated x)))
(improve
(if->match x v (name-selector s) thn els))
(fail)))
(($ app ($ var v) (($ var x)))
(=> fail)
(if (and (name-selector v) (not (name-mutated x)))
(improve
(if->match
x
%false-object?
(name-selector v)
els
thn))
(fail)))
(($ var v)
(=> fail)
(if (not (name-mutated v))
(improve
(if->match
v
%false-object?
(lambda (x) x)
els
thn))
(fail)))
(_ (make-if
(improve tst)
(improve thn)
(improve els)))))))
(define improve-match
(lambda (e clauses)
(let ((clauses
(map (match-lambda
(($ mclause p body fail)
(make-mclause p (improve body) fail)))
clauses)))
(match e
(($ var x)
(if (not (name-mutated x))
(let ((fix-clause
(match-lambda
((and c ($ mclause p e fail))
(if (not (uses-x? e x))
c
(let ((y (rebind-var x)))
(make-mclause
(make-flat-pand (list p (make-pvar y)))
(sub e x y)
fail)))))))
(make-match e (map fix-clause clauses)))
(make-match e clauses)))
(_ (make-match (improve e) clauses))))))
(define uses-x?
(lambda (e x)
(recur loop
((e e))
(match e
(($ and exps) (ormap loop exps))
(($ app fun args)
(or (loop fun) (ormap loop args)))
(($ begin exps) (ormap loop exps))
(($ if e1 e2 e3)
(or (loop e1) (loop e2) (loop e3)))
(($ lam names body) (loop body))
(($ let bindings body)
(or (ormap (match-lambda (($ bind _ b) (loop b)))
bindings)
(loop body)))
(($ let* bindings body)
(or (ormap (match-lambda (($ bind _ b) (loop b)))
bindings)
(loop body)))
(($ letr bindings body)
(or (ormap (match-lambda (($ bind _ b) (loop b)))
bindings)
(loop body)))
(($ or exps) (ormap loop exps))
(($ delay e2) (loop e2))
(($ set! name exp) (or (eq? x name) (loop exp)))
(($ var name) (eq? x name))
(($ vlam names name body) (loop body))
(($ match exp clauses)
(or (loop exp)
(ormap (match-lambda
(($ mclause p b _) (or (loop p) (loop b))))
clauses)))
(($ body defs exps)
(or (ormap loop defs) (ormap loop exps)))
(($ record bindings)
(ormap (match-lambda (($ bind _ b) (loop b)))
bindings))
(($ field _ e) (loop e))
(($ cast _ e) (loop e))
(($ define _ e) (loop e))
((? defstruct?) #f)
((? datatype?) #f)
(($ pand pats) (ormap loop pats))
(($ pnot pat) (loop pat))
(($ pobj c args) (ormap loop args))
(($ ppred pred) (eq? x pred))
(_ #f)))))
(define sub
(lambda (e x to)
(let ((dos (lambda (y) (if (eq? x y) to y))))
(recur sub
((e e))
(match e
(($ define x e) (make-define x (sub e)))
((? defstruct?) e)
((? datatype?) e)
(($ match e clauses)
(let ((clauses
(map (match-lambda
(($ mclause p e fail)
(make-mclause p (sub e) fail)))
clauses)))
(make-match (sub e) clauses)))
(($ if tst thn els)
(make-if (sub tst) (sub thn) (sub els)))
(($ var x) (make-var (dos x)))
((? const? e) e)
(($ lam args e2) (make-lam args (sub e2)))
(($ vlam args rest e2)
(make-vlam args rest (sub e2)))
(($ app e1 args)
(make-app (sub e1) (map sub args)))
(($ begin exps) (make-begin (map sub exps)))
(($ and exps) (make-and (map sub exps)))
(($ or exps) (make-or (map sub exps)))
(($ delay e2) (make-delay (sub e2)))
(($ set! x e2) (make-set! (dos x) (sub e2)))
(($ let args e2)
(let ((args (map (match-lambda
(($ bind x e) (make-bind x (sub e))))
args)))
(make-let args (sub e2))))
(($ let* args e2)
(let ((args (map (match-lambda
(($ bind x e) (make-bind x (sub e))))
args)))
(make-let* args (sub e2))))
(($ letr args e2)
(let ((args (map (match-lambda
(($ bind x e) (make-bind x (sub e))))
args)))
(make-letr args (sub e2))))
(($ body defs exps)
(make-body (map sub defs) (map sub exps)))
(($ record args)
(make-record
(map (match-lambda
(($ bind x e) (make-bind x (sub e))))
args)))
(($ field x e) (make-field x (sub e)))
(($ cast ty e) (make-cast ty (sub e))))))))
(define improve-clauses
(lambda (clauses)
(recur loop
((clauses clauses))
(match clauses
(() '())
((_) clauses)
(((and m1 ($ mclause p _ fail)) . rest)
(cons m1
(if fail
(loop rest)
(recur loop2
((clauses (loop rest)))
(match clauses
(() '())
(((and m ($ mclause p2 body2 fail2))
.
r)
(match (improve-by-pattern p2 p)
(('stop . p)
(cons (make-mclause
p
body2
fail2)
r))
(('redundant . p)
(unless
(null? r)
(printf
"Warning: redundant pattern ~a~%"
(ppat p2)))
(cons (make-mclause
p
body2
fail2)
r))
(('continue . p)
(cons (make-mclause
p
body2
fail2)
(loop2 r))))))))))))))
(define improve-by-pattern
(lambda (p2 p1)
(call-with-current-continuation
(lambda (k)
(let* ((reject (lambda () (k (cons 'continue p2))))
(p1covers #t)
(p2covers #t)
(p3 (recur m
((p1 p1) (p2 p2))
'(printf "(M ~a ~a)~%" (ppat p1) (ppat p2))
(match (cons p1 p2)
((($ pand (a . _)) . p2) (m a p2))
((p1 $ pand (a . b))
(make-flat-pand (cons (m p1 a) b)))
((($ pvar _) . _)
(unless
(or (pvar? p2) (pany? p2))
(set! p2covers #f))
p2)
((($ pany) . _)
(unless
(or (pvar? p2) (pany? p2))
(set! p2covers #f))
p2)
((($ pelse) . _)
'(unless
(or (pvar? p2) (pany? p2))
(set! p2covers #f))
p2)
((_ $ pvar _)
(unless p1covers (reject))
(set! p1covers #f)
(make-flat-pand (list p2 (make-pnot p1))))
((_ $ pany)
(unless p1covers (reject))
(set! p1covers #f)
(make-flat-pand (list p2 (make-pnot p1))))
((_ $ pelse)
(unless p1covers (reject))
(set! p1covers #f)
(make-flat-pand (list p2 (make-pnot p1))))
((($ pconst a _) $ pconst b _)
(unless (equal? a b) (reject))
p2)
((($ pobj tag1 a) $ pobj tag2 b)
(unless (eq? tag1 tag2) (reject))
(make-pobj tag1 (map2 m a b)))
((($ ppred tag1) $ ppred tag2)
(unless (eq? tag1 tag2) (reject))
p2)
((($ ppred tag1) $ pobj tag2 _)
(unless (eq? tag1 tag2) (reject))
(set! p2covers #f)
p2)
((($ ppred tag1) $ pconst c tag2)
(unless (eq? tag1 tag2) (reject))
(set! p2covers #f)
p2)
(_ (reject))))))
(cond (p1covers (cons 'redundant p2))
(p2covers (cons 'stop p3))
(else (cons 'continue p3))))))))
(define improve-by-noisily
(lambda (p2 p1)
(let ((r (improve-by-pattern p2 p1)))
(printf
"~a by ~a returns ~a ~a~%"
(ppat p2)
(ppat p1)
(car r)
(ppat (cdr r))))))
(define make-components
(lambda (d)
(let* ((structs
(filter-map
(match-lambda ((? define?) #f) (x x))
d))
(defs (filter-map
(match-lambda ((? define? x) x) (_ #f))
d))
(name-of (match-lambda (($ define x _) x)))
(ref-of
(match-lambda
(($ define _ e) (references e name-gdef))))
(comp (top-sort defs name-of ref-of)))
(when #f
(printf "Components:~%")
(pretty-print
(map (lambda (c)
(map (match-lambda
(($ define x _) (and x (name-name x))))
c))
comp)))
(append structs comp))))
(define make-body-components
(lambda (d)
(let* ((structs
(filter-map
(match-lambda ((? define?) #f) (x x))
d))
(defs (filter-map
(match-lambda ((? define? x) x) (_ #f))
d))
(name-of (match-lambda (($ define x _) x)))
(bound (map name-of defs))
(ref-of
(match-lambda
(($ define _ e)
(references e (lambda (x) (memq x bound))))))
(comp (top-sort defs name-of ref-of)))
(when #f
(printf "Components:~%")
(pretty-print
(map (lambda (c)
(map (match-lambda
(($ define x _) (and x (name-name x))))
c))
comp)))
(append structs comp))))
(define make-letrec-components
(lambda (bindings)
(let* ((name-of bind-name)
(bound (map name-of bindings))
(ref-of
(match-lambda
(($ bind _ e)
(references e (lambda (x) (memq x bound))))))
(comp (top-sort bindings name-of ref-of)))
(when #f
(printf "Letrec Components:~%")
(pretty-print
(map (lambda (c)
(map (match-lambda (($ bind x _) (pname x))) c))
comp)))
comp)))
(define references
(lambda (e ref?)
(recur loop
((e e))
(match e
(($ define x e)
(if (and x (name-mutated x))
(union (set x) (loop e))
(loop e)))
((? defstruct?) empty-set)
((? datatype?) empty-set)
((? const?) empty-set)
(($ var x) (if (ref? x) (set x) empty-set))
(($ lam _ e1) (loop e1))
(($ vlam _ _ e1) (loop e1))
(($ app e0 args)
(foldr union2 (loop e0) (map loop args)))
(($ let b e2)
(let ((do-bind (match-lambda (($ bind _ e) (loop e)))))
(foldr union2 (loop e2) (map do-bind b))))
(($ let* b e2)
(let ((do-bind (match-lambda (($ bind _ e) (loop e)))))
(foldr union2 (loop e2) (map do-bind b))))
(($ letr b e2)
(let ((do-bind (match-lambda (($ bind _ e) (loop e)))))
(foldr union2 (loop e2) (map do-bind b))))
(($ body defs exps)
(foldr union2
empty-set
(map loop (append defs exps))))
(($ record b)
(let ((do-bind (match-lambda (($ bind _ e) (loop e)))))
(foldr union2 empty-set (map do-bind b))))
(($ field _ e) (loop e))
(($ cast _ e) (loop e))
(($ and exps)
(foldr union2 empty-set (map loop exps)))
(($ or exps)
(foldr union2 empty-set (map loop exps)))
(($ begin exps)
(foldr union2 empty-set (map loop exps)))
(($ if test then els)
(union (loop test) (loop then) (loop els)))
(($ delay e) (loop e))
(($ set! x body)
(union (if (ref? x) (set x) empty-set)
(loop body)))
(($ match exp clauses)
(foldr union2
(loop exp)
(map (match-lambda (($ mclause _ exp _) (loop exp)))
clauses)))))))
(define top-sort
(lambda (graph name-of references-of)
(let* ((adj assq)
(g (map (lambda (x)
(list (name-of x)
(box (references-of x))
(box #f)
x))
graph))
(gt (let ((gt (map (match-lambda
((n _ _ name)
(list n (box empty-set) (box #f) n)))
g)))
(for-each
(match-lambda
((n nay _ _)
(for-each
(lambda (v)
(match (adj v gt)
(#f #f)
((_ b _ _) (set-box! b (cons n (unbox b))))))
(unbox nay))))
g)
gt))
(visit (lambda (vg)
(letrec ((visit (lambda (g l)
(match g
(#f l)
((n nay mark name)
(if (unbox mark)
l
(begin
(set-box! mark #t)
(cons name
(foldr (lambda (v l)
(visit (adj v
vg)
l))
l
(unbox nay))))))))))
visit)))
(visit-gt (visit gt))
(visit-g (visit g))
(post (foldr visit-gt '() gt))
(pre (foldl (lambda (gg l)
(match (visit-g (adj gg g) '())
(() l)
(c (cons c l))))
'()
post)))
(reverse pre))))
(define genlet #t)
(define genmatch #t)
(define letonce #f)
(define type-defs
(lambda (d)
(for-each
(match-lambda
((? defstruct? b) (type-structure b))
((? datatype? b) (type-structure b))
(c (type-component c #t)))
(make-components d))
(close '())))
(define type-structure
(match-lambda
(($ defstruct
x
_
make
pred
get
set
getn
setn
mutable)
(let* ((vars (map (lambda (_) (gensym)) get))
(make-get-type
(lambda (getter v)
(match getter
(($ some b)
(set-name-ty!
b
(closeall
(r+ initial-type-env `((,x ,@vars) -> ,v)))))
(_ #f))))
(make-set-type
(lambda (setter v)
(match setter
(($ some b)
(set-name-ty!
b
(closeall
(r+ initial-type-env `((,x ,@vars) ,v -> void)))))
(_ #f)))))
(set-name-ty!
make
(closeall
(r+ initial-type-env `(,@vars -> (,x ,@vars)))))
(set-name-ty!
pred
(closeall
(r+ initial-type-env
`((+ (,x ,@vars) y) -> bool))))
(for-each2 make-get-type get vars)
(for-each2 make-set-type set vars)
(for-each2 make-get-type getn vars)
(for-each2 make-set-type setn vars)))
(($ datatype dt)
(for-each
(match-lambda
((type . variants)
(for-each
(match-lambda
(($ variant con pred arg-types)
(set-name-ty!
con
(closeall
(r+ initial-type-env
`(,@(cdr arg-types) -> ,type))))
(set-name-ty!
pred
(closeall
(r+ initial-type-env
`((+ ,(name-predicate pred) x) -> bool))))))
variants)))
dt))))
(define type-component
(lambda (component top)
(when verbose
(let ((cnames
(filter-map
(match-lambda (($ define b _) (name-name b)))
component)))
(unless
(null? cnames)
(printf "Typing ~a~%" cnames))))
(let* ((f (match-lambda (($ define b e) (make-bind b e))))
(bindings (map f component))
(names (map (match-lambda (($ define b _) (pname b)))
component))
(f1 (match-lambda
(($ define b _) (set-name-ty! b (tvar)))))
(f2 (match-lambda
((and d ($ define b e))
(set-define-exp! d (w e names)))))
(f3 (match-lambda
(($ define b e) (unify (name-ty b) (typeof e)))))
(f4 (match-lambda (($ define b _) (name-ty b))))
(f5 (lambda (d ts)
(match d (($ define b _) (set-name-ty! b ts))))))
(push-level)
(for-each f1 component)
(for-each f2 component)
(for-each f3 component)
(for-each limit-expansive component)
(for-each
f5
component
(close (map f4 component)))
(pop-level))))
(define w
(lambda (e component)
(match e
(($ const _ pred)
(make-type
(r+ initial-type-env (name-predicate pred))
e))
(($ var x)
(unless
(name-ty x)
(set-name-ty!
x
(if (name-mutated x)
(monotvar)
(let* ((_1 (push-level))
(t (closeall (tvar)))
(_2 (pop-level)))
t))))
(if (ts? (name-ty x))
(match-let*
((tynode (make-type #f #f))
((t absv) (instantiate (name-ty x) tynode)))
(set-type-ty! tynode t)
(set-type-exp!
tynode
(match (name-primitive x)
('imprecise
(make-check (list absv #f #f #f component) e))
('check
(make-check
(list (cons top absv) #f #f #f component)
e))
('nocheck e)
(#t
(make-check
(list absv (mk-definite-prim t) #f #f component)
e))
(#f
(make-check (list absv #f #f #t component) e))))
tynode)
e))
(($ lam x e1)
(for-each (lambda (b) (set-name-ty! b (tvar))) x)
(match-let*
((body (w e1 component))
((t absv)
(r+collect
initial-type-env
`(,@(map name-ty x) -> ,(typeof body)))))
(make-type
t
(make-check
(list absv (mk-definite-lam t) #f #f component)
(make-lam x body)))))
(($ vlam x rest e1)
(for-each (lambda (b) (set-name-ty! b (tvar))) x)
(match-let*
((z (tvar))
(_ (set-name-ty!
rest
(r+ initial-type-env `(list ,z))))
(body (w e1 component))
((t absv)
(r+collect
initial-type-env
`(,@(map name-ty x) (&list ,z) -> ,(typeof body)))))
(make-type
t
(make-check
(list absv (mk-definite-lam t) #f #f component)
(make-vlam x rest body)))))
(($ app e0 args)
(match-let*
((t0 (w e0 component))
(targs (maplr (lambda (e) (w e component)) args))
(a* (map (lambda (_) (tvar)) args))
(b (tvar))
((t absv)
(r-collect initial-type-env `(,@a* -> ,b)))
(definf (mk-definite-app t)))
(unify (typeof t0) t)
(for-each2 unify (map typeof targs) a*)
(if (syntactically-a-procedure? t0)
(make-type b (make-app t0 targs))
(make-type
b
(make-check
(list absv definf #f #f component)
(make-app t0 targs))))))
(($ let b e2)
(let* ((do-bind
(match-lambda
(($ bind b e)
(if genlet
(let* ((_ (push-level))
(e (w e (list (pname b))))
(bind (make-bind b e)))
(limit-expansive bind)
(set-name-ty! b (car (close (list (typeof e)))))
(pop-level)
bind)
(let ((e (w e component)))
(set-name-ty! b (typeof e))
(make-bind b e))))))
(tb (map do-bind b))
(body (w e2 component)))
(make-let tb body)))
(($ let* b e2)
(let* ((do-bind
(match-lambda
(($ bind b e)
(if genlet
(let* ((_ (push-level))
(e (w e (list (pname b))))
(bind (make-bind b e)))
(limit-expansive bind)
(set-name-ty! b (car (close (list (typeof e)))))
(pop-level)
bind)
(let ((e (w e component)))
(set-name-ty! b (typeof e))
(make-bind b e))))))
(tb (maplr do-bind b))
(body (w e2 component)))
(make-let* tb body)))
(($ letr b e2)
(let* ((do-comp
(lambda (b)
(if genlet
(let* ((f1 (match-lambda
(($ bind b _) (set-name-ty! b (tvar)))))
(names (map (match-lambda
(($ bind b _) (pname b)))
b))
(f2 (match-lambda
(($ bind b e)
(make-bind b (w e names)))))
(f3 (match-lambda
(($ bind b e)
(unify (name-ty b) (typeof e))
(name-ty b))))
(f4 (lambda (bind ts)
(match bind
(($ bind b _)
(set-name-ty! b ts)))))
(_1 (push-level))
(_2 (for-each f1 b))
(tb (maplr f2 b))
(_3 (for-each limit-expansive tb))
(ts-list (close (maplr f3 tb))))
(pop-level)
(for-each2 f4 tb ts-list)
tb)
(let* ((f1 (match-lambda
(($ bind b _) (set-name-ty! b (tvar)))))
(f2 (match-lambda
(($ bind b e)
(make-bind b (w e component)))))
(f3 (match-lambda
(($ bind b e)
(unify (name-ty b) (typeof e)))))
(_1 (for-each f1 b))
(tb (maplr f2 b)))
(for-each f3 tb)
tb))))
(comps (make-letrec-components b))
(tb (foldr append '() (maplr do-comp comps))))
(make-letr tb (w e2 component))))
(($ body defs exps)
(for-each
(match-lambda
((? defstruct? b) (type-structure b))
((? datatype? b) (type-structure b))
(c (type-component c #f)))
(make-body-components defs))
(let ((texps (maplr (lambda (x) (w x component)) exps)))
(make-body defs texps)))
(($ and exps)
(let* ((texps (maplr (lambda (x) (w x component)) exps))
(t (match texps
(() (r+ initial-type-env 'true))
((e) (typeof e))
(_ (let ((a (r+ initial-type-env 'false)))
(unify (typeof (rac texps)) a)
a)))))
(make-type t (make-and texps))))
(($ or exps)
(let* ((texps (maplr (lambda (x) (w x component)) exps))
(t (match texps
(() (r+ initial-type-env 'false))
((e) (typeof e))
(_ (let* ((t-last (typeof (rac texps)))
(but-last (rdc texps))
(a (tvar)))
(for-each
(lambda (e)
(unify (typeof e)
(r+ initial-type-env
`(+ (not false) ,a))))
but-last)
(unify t-last
(r+ initial-type-env
`(+ (not false) ,a)))
t-last)))))
(make-type t (make-or texps))))
(($ begin exps)
(let ((texps (maplr (lambda (x) (w x component)) exps)))
(make-begin texps)))
(($ if test then els)
(let ((ttest (w test component))
(tthen (w then component))
(tels (w els component))
(a (tvar)))
(unify (typeof tthen) a)
(unify (typeof tels) a)
(make-type a (make-if ttest tthen tels))))
(($ delay e2)
(let ((texp (w e2 component)))
(make-type
(r+ initial-type-env `(promise ,(typeof texp)))
(make-delay texp))))
(($ set! x body)
(unless (name-ty x) (set-name-ty! x (monotvar)))
(let* ((body (w body component))
(t (if (ts? (name-ty x))
(car (instantiate (name-ty x) #f))
(name-ty x))))
(unify t (typeof body))
(make-type
(r+ initial-type-env 'void)
(make-set! x body))))
(($ record bind)
(let* ((tbind (map (match-lambda
(($ bind name exp)
(make-bind name (w exp component))))
bind))
(t (r+ initial-type-env
`(record
,@(map (match-lambda
(($ bind name exp)
(list name (typeof exp))))
tbind)))))
(make-type t (make-record tbind))))
(($ field name exp)
(match-let*
((texp (w exp component))
(a (tvar))
((t absv)
(r-collect initial-type-env `(record (,name ,a)))))
(unify (typeof texp) t)
(make-type
a
(make-check
(list absv #f #f #f component)
(make-field name texp)))))
(($ cast (ty t absv) exp)
(let ((texp (w exp component)) (a (tvar)))
(unify (r+ initial-type-env `(,(typeof texp) -> ,a))
t)
(make-type
a
(make-check
(list absv #f #f #f component)
(make-cast (list ty t absv) texp)))))
(($ match exp clauses)
(for-each
(match-lambda
(($ mclause p _ (? name? fail))
(set-name-ty!
fail
(r+ initial-type-env '(a ?-> b))))
(_ #f))
clauses)
(match-let*
((iclauses
(improve-clauses
(append
clauses
(list (make-mclause (make-pelse) #f #f)))))
((tmatch absv precise)
(w-match (rdc iclauses) (rac iclauses)))
(texp (w exp component))
(_ (unify (typeof texp) tmatch))
(tclauses
(maplr (match-lambda
(($ mclause p e fail)
(make-mclause p (w e component) fail)))
clauses))
(a (tvar)))
(for-each
(match-lambda
(($ mclause _ e _) (unify (typeof e) a)))
tclauses)
(make-type
a
(make-check
(list absv #f (not precise) #f component)
(make-match texp tclauses))))))))
(define w-match
(lambda (clauses last)
(letrec ((bindings '())
(encode
(match-lambda
(($ pand pats) (encode* pats))
(x (encode* (list x)))))
(encode*
(lambda (pats)
(let* ((concrete?
(lambda (p)
(or (pconst? p) (pobj? p) (ppred? p) (pelse? p))))
(var? (lambda (p) (or (pvar? p) (pany? p))))
(not-var?
(lambda (p)
(and (not (pvar? p)) (not (pany? p)))))
(t (match (filter concrete? pats)
((p)
(r+ initial-type-env
(match (template p)
((x) x)
(x `(+ ,@x)))))
(()
(r+ initial-type-env
`(+ ,@(apply append
(map template
(filter
not-var?
pats)))
,@(if (null? (filter var? pats))
'()
(list (out1tvar)))))))))
(for-each
(match-lambda
(($ pvar b)
(set! bindings (cons b bindings))
(set-name-ty! b (pat-var-bind t))))
(filter pvar? pats))
t)))
(template
(match-lambda
((? pelse?) '())
(($ pconst _ pred) (list (name-predicate pred)))
((and pat ($ pobj c args))
(list (cond ((or (eq? %vector? c) (eq? %cvector? c))
(cons (if (eq? %vector? c) 'vec 'cvec)
(match (maplr encode args)
(() (list (out1tvar)))
((first . rest)
(list (foldr (lambda (x y)
(unify x y)
y)
first
rest))))))
(else
(cons (car (name-predicate c))
(maplr encode args))))))
(($ ppred pred)
(cond ((eq? pred %boolean?) (list 'true 'false))
((eq? pred %list?) (list `(list ,(out1tvar))))
(else
(list (cons (car (name-predicate pred))
(maplr (lambda (_) (out1tvar))
(cdr (name-predicate pred))))))))
(($ pnot (? pconst?)) '())
(($ pnot ($ ppred pred))
(cond ((eq? pred %boolean?) '((not true) (not false)))
((eq? pred %procedure?) '((not ?->)))
((eq? pred %list?) '())
(else `((not ,(car (name-predicate pred)))))))
(($ pnot ($ pobj pred pats))
(let ((m (foldr + 0 (map non-triv pats))))
(case m
((0) `((not ,(car (name-predicate pred)))))
((1)
`((,(car (name-predicate pred))
,@(map (match-lambda
(($ pobj pred _)
`(+ (not ,(car (name-predicate pred)))
,(out1tvar)))
(($ ppred pred)
`(+ (not ,(car (name-predicate pred)))
,(out1tvar)))
(_ (out1tvar)))
pats))))
(else '()))))))
(non-triv
(match-lambda
((? pvar?) 0)
((? pany?) 0)
((? pelse?) 0)
((? pconst?) 2)
(($ pobj _ pats) (foldr + 1 (map non-triv pats)))
(_ 1)))
(precise
(match-lambda
((? pconst?) #f)
(($ pand pats) (andmap precise pats))
(($ pnot pat) (precise pat))
(($ pobj pred pats)
(let ((m (foldr + 0 (map non-triv pats))))
(case m
((0) #t)
((1) (andmap precise pats))
(else #f))))
(($ ppred pred) (not (eq? pred %list?)))
(_ #t))))
(push-level)
(match-let*
((precise-match
(and (andmap
(match-lambda (($ mclause _ _ fail) (not fail)))
clauses)
(match last (($ mclause p _ _) (precise p)))))
(types (maplr (match-lambda (($ mclause p _ _) (encode p)))
clauses))
((t absv)
(r-match
(foldr (lambda (x y) (unify x y) y) (tvar) types))))
(unify (out1tvar) t)
(for-each limit-name bindings)
(for-each2
set-name-ty!
bindings
(close (map name-ty bindings)))
(pop-level)
'(pretty-print
`(match-input
,@(map (match-lambda (($ mclause p _ _) (ppat p)))
clauses)))
'(pretty-print
`(match-type
,(ptype t)
,@(map (lambda (b) (list (pname b) (ptype (name-ty b))))
bindings)))
(list t absv precise-match)))))
(define syntactically-a-procedure?
(match-lambda
(($ type _ e) (syntactically-a-procedure? e))
(($ check _ e) (syntactically-a-procedure? e))
(($ var x) (name-primitive x))
((? lam?) #t)
((? vlam?) #t)
(($ let _ body)
(syntactically-a-procedure? body))
(($ let* _ body)
(syntactically-a-procedure? body))
(($ letr _ body)
(syntactically-a-procedure? body))
(($ if _ e2 e3)
(and (syntactically-a-procedure? e2)
(syntactically-a-procedure? e3)))
(($ begin exps)
(syntactically-a-procedure? (rac exps)))
(($ body _ exps)
(syntactically-a-procedure? (rac exps)))
(_ #f)))
(define typeof
(match-lambda
(($ type t _) t)
(($ check _ e) (typeof e))
(($ let _ body) (typeof body))
(($ let* _ body) (typeof body))
(($ letr _ body) (typeof body))
(($ body _ exps) (typeof (rac exps)))
(($ begin exps) (typeof (rac exps)))
(($ var x) (name-ty x))))
(define limit-name
(lambda (n)
(when (name-mutated n)
(unify (name-ty n) (out1tvar)))))
(define limit-expansive
(letrec ((limit! (lambda (t) (unify t (out1tvar))))
(expansive-pattern?
(match-lambda
((? pconst?) #f)
(($ pvar x) (name-mutated x))
(($ pobj _ pats) (ormap expansive-pattern? pats))
((? pany?) #f)
((? pelse?) #f)
(($ pand pats) (ormap expansive-pattern? pats))
(($ ppred x) (name-mutated x))
(($ pnot pat) (expansive-pattern? pat))))
(limit-expr
(match-lambda
(($ bind b e)
(if (name-mutated b)
(limit! (typeof e))
(limit-expr e)))
((? defstruct?) #f)
((? datatype?) #f)
(($ define x e)
(if (and x (name-mutated x))
(limit! (typeof e))
(limit-expr e)))
(($ type
t
($ app ($ type _ ($ check _ ($ var x))) exps))
(cond ((list? (name-pure x))
(if (= (length (name-pure x)) (length exps))
(for-each2
(lambda (pure e)
(if pure (limit-expr e) (limit! (typeof e))))
(name-pure x)
exps)
(limit! t)))
((or (eq? #t (name-pure x))
(and (eq? 'cons (name-pure x))
(not cons-is-mutable)))
(for-each limit-expr exps))
(else (limit! t))))
(($ type t ($ app _ _)) (limit! t))
(($ type t ($ check _ ($ app _ _))) (limit! t))
(($ delay _) #f)
(($ type t ($ set! _ _)) (limit! t))
(($ var _) #f)
((? const?) #f)
(($ lam _ _) #f)
(($ vlam _ _ _) #f)
(($ let bind body)
(limit-expr body)
(for-each limit-expr bind))
(($ let* bind body)
(limit-expr body)
(for-each limit-expr bind))
(($ letr bind body)
(limit-expr body)
(for-each limit-expr bind))
(($ body defs exps)
(for-each limit-expr defs)
(for-each limit-expr exps))
(($ and exps) (for-each limit-expr exps))
(($ or exps) (for-each limit-expr exps))
(($ begin exps) (for-each limit-expr exps))
(($ if e1 e2 e3)
(limit-expr e1)
(limit-expr e2)
(limit-expr e3))
(($ record bind)
(for-each
(match-lambda (($ bind _ e) (limit-expr e)))
bind))
(($ field _ exp) (limit-expr exp))
(($ cast _ exp) (limit-expr exp))
(($ match exp clauses)
(limit-expr exp)
(for-each
(match-lambda
(($ mclause pat body fail)
(if (or (and fail (name-mutated fail))
(expansive-pattern? pat))
(limit! (typeof body))
(limit-expr body))))
clauses))
(($ type _ e1) (limit-expr e1))
(($ check _ e1) (limit-expr e1)))))
limit-expr))
(define unparse
(lambda (e check-action)
(letrec ((pbind (match-lambda
(($ bind n e) (list (pname n) (pexpr e)))))
(pexpr (match-lambda
((and x ($ type _ (? check?)))
(check-action x pexpr))
(($ type _ exp) (pexpr exp))
(($ shape t exp) (pexpr exp))
(($ define x e)
(if (or (not x) (and (name? x) (not (name-name x))))
(pexpr e)
`(define ,(pname x) ,(pexpr e))))
(($ defstruct _ args _ _ _ _ _ _ _)
`(check-define-const-structure ,args))
(($ datatype d)
`(datatype
,@(map (match-lambda
(((tag . args) . bindings)
(cons (cons (ptag tag) args)
(map (match-lambda
(($ variant _ _ types) types))
bindings))))
d)))
(($ and exps) `(and ,@(maplr pexpr exps)))
(($ or exps) `(or ,@(maplr pexpr exps)))
(($ begin exps) `(begin ,@(maplr pexpr exps)))
(($ var x) (pname x))
(($ prim x) (pname x))
(($ const x _) (pconst x))
(($ lam x e1)
`(lambda ,(maplr pname x) ,@(pexpr e1)))
(($ vlam x rest e1)
`(lambda ,(append (maplr pname x) (pname rest))
,@(pexpr e1)))
(($ match e1 clauses)
(let* ((pclause
(match-lambda
(($ mclause p #f #f)
`(,(ppat p) <last clause>))
(($ mclause p exp fail)
(if fail
`(,(ppat p)
(=> ,(pname fail))
,@(pexpr exp))
`(,(ppat p) ,@(pexpr exp))))))
(p1 (pexpr e1)))
`(match ,p1 ,@(maplr pclause clauses))))
(($ app e1 args)
(let* ((p1 (pexpr e1))
(pargs (maplr pexpr args))
(unkwote
(match-lambda
(('quote x) x)
((? boolean? x) x)
((? number? x) x)
((? char? x) x)
((? string? x) x)
((? null? x) x)
((? box? x) x)
((? vector? x) x))))
(cond ((eq? p1 qlist) `',(maplr unkwote pargs))
((eq? p1 qcons)
(let ((unq (maplr unkwote pargs)))
`',(cons (car unq) (cadr unq))))
((eq? p1 qbox) (box (unkwote (car pargs))))
((eq? p1 qvector)
(list->vector (maplr unkwote pargs)))
(else (cons p1 pargs)))))
(($ let b e2)
(let ((pb (maplr pbind b)))
`(let ,pb ,@(pexpr e2))))
(($ let* b e2)
(let ((pb (maplr pbind b)))
`(let* ,pb ,@(pexpr e2))))
(($ letr b e2)
(let ((pb (maplr pbind b)))
`(letrec ,pb ,@(pexpr e2))))
(($ body defs exps)
(let ((pdefs (maplr pexpr defs)))
(append pdefs (maplr pexpr exps))))
(($ if e1 e2 e3)
(let* ((p1 (pexpr e1)) (p2 (pexpr e2)) (p3 (pexpr e3)))
`(if ,p1 ,p2 ,p3)))
(($ record bindings)
`(record ,@(maplr pbind bindings)))
(($ field x e2) `(field ,x ,(pexpr e2)))
(($ cast (ty . _) e2) `(: ,ty ,(pexpr e2)))
(($ delay e) `(delay ,(pexpr e)))
(($ set! x e) `(set! ,(pname x) ,(pexpr e))))))
(pexpr e))))
(define pexpr
(lambda (ex)
(unparse
ex
(lambda (e pexpr)
(match e
(($ type _ ($ check _ exp)) (pexpr exp)))))))
(define pdef pexpr)
(define ppat
(match-lambda
(($ pconst x _) (pconst x))
(($ pvar x) (pname x))
(($ pany) '_)
(($ pelse) 'else)
(($ pnot pat) `(not ,(ppat pat)))
(($ pand pats) `(and ,@(maplr ppat pats)))
(($ ppred pred)
(match (pname pred)
('false-object? #f)
('true-object? #t)
('null? '())
(x `(? ,x))))
(($ pobj tag args)
(match (cons (pname tag) args)
(('box? x) (box (ppat x)))
(('pair? x y) (cons (ppat x) (ppat y)))
(('vector? . x) (list->vector (maplr ppat x)))
((tg . _) `($ ,(strip-? tg) ,@(maplr ppat args)))))))
(define strip-?
(lambda (s)
(let* ((str (symbol->string s))
(n (string-length str)))
(if (or (zero? n)
(not (char=? #\? (string-ref str (- n 1)))))
s
(string->symbol (substring str 0 (- n 1)))))))
(define pname
(match-lambda
((? name? x) (or (name-name x) '<expr>))
((? symbol? x) x)))
(define ptag
(match-lambda
((? k? k) (k-name k))
((? symbol? x) x)))
(define pconst
(match-lambda
((? symbol? x) `',x)
((? boolean? x) x)
((? number? x) x)
((? char? x) x)
((? string? x) x)
((? null? x) `',x)))
(define check
(lambda (file)
(output-checked file '() type-check?)))
(define profcheck
(lambda (file)
(output-checked #f '() type-check?)
(output-checked
#f
(make-counters total-possible)
type-check?)))
(define fullcheck
(lambda (file)
(let ((check? (lambda (_) #t)))
(output-checked #f '() check?)
(output-checked
#f
(make-counters total-possible)
check?))))
(define make-counters
(lambda (n)
(let* ((init `(define check-counters (make-vector ,n 0)))
(sum '(define check-total
(lambda ()
(let ((foldr (lambda (f i l)
(recur loop
((l l))
(match l
(() i)
((x . y) (f x (loop y))))))))
(foldr + 0 (vector->list check-counters))))))
(incr '(extend-syntax
(check-increment-counter)
((check-increment-counter c)
(vector-set!
check-counters
c
(+ 1 (vector-ref check-counters c)))))))
(list init sum incr))))
(define output-checked
(lambda (file header check-test)
(set! summary '())
(set! total-possible 0)
(set! total-cast 0)
(set! total-err 0)
(set! total-any 0)
(let ((doit (lambda ()
(when (string? file)
(printf
";; Generated by Soft Scheme ~a~%"
st:version)
(printf ";; (st:control")
(for-each
(lambda (x) (printf " '~a" x))
(show-controls))
(printf ")~%")
(unless
(= 0 n-unbound)
(printf
";; CAUTION: ~a unbound references, this code is not safe~%"
n-unbound))
(printf "~%")
(for-each pretty-print header))
(for-each
(lambda (exp)
(match exp
(($ define x _)
(set! n-possible 0)
(set! n-clash 0)
(set! n-err 0)
(set! n-match 0)
(set! n-inexhaust 0)
(set! n-prim 0)
(set! n-lam 0)
(set! n-app 0)
(set! n-field 0)
(set! n-cast 0)
(if file
(pretty-print (pcheck exp check-test))
(pcheck exp check-test))
(make-summary-line x)
(set! total-possible
(+ total-possible n-possible))
(set! total-cast (+ total-cast n-cast))
(set! total-err (+ total-err n-err))
(set! total-any
(+ total-any
n-match
n-inexhaust
n-prim
n-lam
n-app
n-field
n-cast)))
(_ (when file
(pretty-print
(pcheck exp check-test))))))
tree)
(when (string? file)
(newline)
(newline)
(print-summary "; ")))))
(if (string? file)
(begin
(delete-file file)
(with-output-to-file file doit))
(doit)))))
(define total-possible 0)
(define total-err 0)
(define total-cast 0)
(define total-any 0)
(define n-possible 0)
(define n-clash 0)
(define n-err 0)
(define n-match 0)
(define n-inexhaust 0)
(define n-prim 0)
(define n-lam 0)
(define n-app 0)
(define n-field 0)
(define n-cast 0)
(define summary '())
(define make-summary-line
(lambda (x)
(let ((total (+ n-match
n-inexhaust
n-prim
n-lam
n-app
n-field
n-cast)))
(unless
(= 0 total)
(let* ((s (sprintf
"~a~a "
(padr (pname x) 16)
(padl total 2)))
(s (cond ((< 0 n-inexhaust)
(sprintf
"~a (~a match ~a inexhaust)"
s
n-match
n-inexhaust))
((< 0 n-match)
(sprintf "~a (~a match)" s n-match))
(else s)))
(s (if (< 0 n-prim)
(sprintf "~a (~a prim)" s n-prim)
s))
(s (if (< 0 n-field)
(sprintf "~a (~a field)" s n-field)
s))
(s (if (< 0 n-lam)
(sprintf "~a (~a lambda)" s n-lam)
s))
(s (if (< 0 n-app) (sprintf "~a (~a ap)" s n-app) s))
(s (if (< 0 n-err)
(sprintf "~a (~a ERROR)" s n-err)
s))
(s (if (< 0 n-cast)
(sprintf "~a (~a TYPE)" s n-cast)
s)))
(set! summary (cons s summary)))))))
(define print-summary
(lambda (hdr)
(for-each
(lambda (s) (printf "~a~a~%" hdr s))
(reverse summary))
(printf
"~a~a~a "
hdr
(padr "TOTAL CHECKS" 16)
(padl total-any 2))
(printf
" (of ~s is ~s%)"
total-possible
(if (= 0 total-possible)
0
(string->number
(chop-number
(exact->inexact
(* (/ total-any total-possible) 100))
4))))
(when (< 0 total-err)
(printf " (~s ERROR)" total-err))
(when (< 0 total-cast)
(printf " (~s TYPE)" total-cast))
(printf "~%")))
(define padl
(lambda (arg n)
(let ((s (sprintf "~a" arg)))
(recur loop
((s s))
(if (< (string-length s) n)
(loop (string-append " " s))
s)))))
(define padr
(lambda (arg n)
(let ((s (sprintf "~a" arg)))
(recur loop
((s s))
(if (< (string-length s) n)
(loop (string-append s " "))
s)))))
(define chop-number
(lambda (x n)
(substring
(sprintf "~s00000000000000000000" x)
0
(- n 1))))
(define pcheck
(lambda (ex check-test)
(unparse
ex
(lambda (e pexpr)
(match e
((and z ($ type _ ($ check inf ($ var x))))
(cond ((name-primitive x)
(set! n-possible (+ 1 n-possible))
(match (check-test inf)
(#f (pname x))
('def
(set! n-err (+ 1 n-err))
(set! n-prim (+ 1 n-prim))
`(,(symbol-append "CHECK-" (pname x))
,(tree-index z)
',(string->symbol "ERROR")))
(_ (set! n-prim (+ 1 n-prim))
`(,(symbol-append "CHECK-" (pname x))
,(tree-index z)))))
((name-unbound? x) `(check-bound ,(pname x)))
(else
(if (check-test inf)
(begin
(set! n-clash (+ 1 n-clash))
`(,(string->symbol "CLASH")
,(pname x)
,(tree-index z)))
(pname x)))))
((and z
($ type _ ($ check inf (and m ($ lam x e1)))))
(set! n-possible (+ 1 n-possible))
(match (check-test inf)
(#f (pexpr m))
('def
(set! n-err (+ 1 n-err))
(set! n-lam (+ 1 n-lam))
`(,(string->symbol "CHECK-lambda")
(,(tree-index z) ',(string->symbol "ERROR"))
,(map pname x)
,@(pexpr e1)))
(_ (set! n-lam (+ 1 n-lam))
`(,(string->symbol "CHECK-lambda")
(,(tree-index z))
,(map pname x)
,@(pexpr e1)))))
((and z
($ type
_
($ check inf (and m ($ vlam x rest e1)))))
(set! n-possible (+ 1 n-possible))
(match (check-test inf)
(#f (pexpr m))
('def
(set! n-err (+ 1 n-err))
(set! n-lam (+ 1 n-lam))
`(,(string->symbol "CHECK-lambda")
(,(tree-index z) ',(string->symbol "ERROR"))
,(append (map pname x) (pname rest))
,@(pexpr e1)))
(_ (set! n-lam (+ 1 n-lam))
`(,(string->symbol "CHECK-lambda")
(,(tree-index z))
,(append (map pname x) (pname rest))
,@(pexpr e1)))))
((and z
($ type _ ($ check inf (and m ($ app e1 args)))))
(set! n-possible (+ 1 n-possible))
(match (check-test inf)
(#f (pexpr m))
('def
(set! n-err (+ 1 n-err))
(set! n-app (+ 1 n-app))
`(,(string->symbol "CHECK-ap")
(,(tree-index z) ',(string->symbol "ERROR"))
,(pexpr e1)
,@(map pexpr args)))
(_ (set! n-app (+ 1 n-app))
(let ((p1 (pexpr e1)))
`(,(string->symbol "CHECK-ap")
(,(tree-index z))
,p1
,@(map pexpr args))))))
((and z
($ type _ ($ check inf (and m ($ field x e1)))))
(set! n-possible (+ 1 n-possible))
(match (check-test inf)
(#f (pexpr m))
('def
(set! n-err (+ 1 n-err))
(set! n-field (+ 1 n-field))
`(,(string->symbol "CHECK-field")
(,(tree-index z) ',(string->symbol "ERROR"))
,x
,(pexpr e1)))
(_ (set! n-field (+ 1 n-field))
`(,(string->symbol "CHECK-field")
(,(tree-index z))
,x
,(pexpr e1)))))
((and z
($ type
_
($ check inf (and m ($ cast (x . _) e1)))))
(set! n-possible (+ 1 n-possible))
(match (check-test inf)
(#f (pexpr m))
(_ (set! n-cast (+ 1 n-cast))
`(,(string->symbol "CHECK-:")
(,(tree-index z))
,x
,(pexpr e1)))))
((and z
($ type
_
($ check inf (and m ($ match e1 clauses)))))
(set! n-possible (+ 1 n-possible))
(match (check-test inf)
(#f (pexpr m))
(inx (let* ((pclause
(match-lambda
(($ mclause p exp fail)
(if fail
`(,(ppat p)
(=> ,(pname fail))
,@(pexpr exp))
`(,(ppat p) ,@(pexpr exp))))))
(p1 (pexpr e1)))
(if (eq? 'inexhaust inx)
(begin
(set! n-inexhaust (+ 1 n-inexhaust))
`(,(string->symbol "CHECK-match")
(,(tree-index z)
,(string->symbol "INEXHAUST"))
,p1
,@(maplr pclause clauses)))
(begin
(set! n-match (+ 1 n-match))
`(,(string->symbol "CHECK-match")
(,(tree-index z))
,p1
,@(maplr pclause clauses)))))))))))))
(define tree-index-list '())
(define reinit-output!
(lambda () (set! tree-index-list '())))
(define tree-index
(lambda (syntax)
(match (assq syntax tree-index-list)
(#f
(let ((n (length tree-index-list)))
(set! tree-index-list
(cons (cons syntax n) tree-index-list))
n))
((_ . n) n))))
(define tree-unindex
(lambda (n)
(let ((max (length tree-index-list)))
(when (<= max n)
(use-error "Invalid CHECK number ~a" n))
(car (list-ref tree-index-list (- (- max 1) n))))))
(define cause
(lambda ()
(for-each
(lambda (def)
(for-each pretty-print (exp-cause def)))
tree)))
(define cause*
(lambda names
(if (null? names)
(for-each
(lambda (def)
(for-each pretty-print (exp-cause def)))
tree)
(for-each
(match-lambda
((? symbol? dname)
(for-each
pretty-print
(exp-cause (find-global dname)))))
names))))
(define exp-cause
(let ((sum (lambda (exps)
(foldr (lambda (x y) (append (exp-cause x) y))
'()
exps)))
(src (lambda (inf)
(let ((nonlocal (map tree-index (check-sources inf))))
(if (type-check1? inf)
(cons (check-local-sources inf) nonlocal)
nonlocal)))))
(match-lambda
((and z ($ type ty ($ check inf ($ var x))))
(if (name-primitive x)
(if (type-check? inf)
(list `((,(symbol-append 'check- (pname x))
,(tree-index z))
,@(src inf)))
'())
(if (type-check1? inf)
(list `((clash ,(pname x) ,(tree-index z)) ,@(src inf)))
'())))
((and z ($ type ty ($ check inf ($ lam x e1))))
(append
(if (type-check? inf)
(list `((check-lambda ,(tree-index z) ,(map pname x) ...)
,@(src inf)))
'())
(exp-cause e1)))
((and z
($ type ty ($ check inf ($ vlam x rest e1))))
(append
(if (type-check? inf)
(list `((check-lambda
,(tree-index z)
,(append (map pname x) (pname rest))
...)
,@(src inf)))
'())
(exp-cause e1)))
((and z ($ type _ ($ check inf ($ app e1 args))))
(append
(if (type-check? inf)
(list `((check-ap ,(tree-index z)) ,@(src inf)))
'())
(exp-cause e1)
(sum args)))
((and z ($ type _ ($ check inf ($ field x e1))))
(append
(if (type-check? inf)
(list `((check-field ,(tree-index z) ,x ...)
,@(src inf)))
'())
(exp-cause e1)))
((and z
($ type _ ($ check inf ($ cast (x . _) e1))))
(append
(if (type-check? inf)
(list `((check-: ,(tree-index z) ,x ...) ,@(src inf)))
'())
(exp-cause e1)))
((and z
($ type
_
($ check inf (and m ($ match e1 clauses)))))
(append
(if (type-check? inf)
(list `((check-match ,(tree-index z) ...) ,@(src inf)))
'())
(exp-cause m)))
(($ define _ e) (exp-cause e))
((? defstruct?) '())
((? datatype?) '())
(($ app e1 args) (sum (cons e1 args)))
(($ match exp clauses)
(foldr (lambda (x y)
(append
(match x (($ mclause _ e _) (exp-cause e)))
y))
(exp-cause exp)
clauses))
(($ var _) '())
(($ and exps) (sum exps))
(($ begin exps) (sum exps))
((? const?) '())
(($ if test then els)
(append
(exp-cause test)
(exp-cause then)
(exp-cause els)))
(($ let bindings body)
(foldr (lambda (x y)
(append (match x (($ bind _ e) (exp-cause e))) y))
(exp-cause body)
bindings))
(($ let* bindings body)
(foldr (lambda (x y)
(append (match x (($ bind _ e) (exp-cause e))) y))
(exp-cause body)
bindings))
(($ letr bindings body)
(foldr (lambda (x y)
(append (match x (($ bind _ e) (exp-cause e))) y))
(exp-cause body)
bindings))
(($ body defs exps) (sum (append defs exps)))
(($ or exps) (sum exps))
(($ delay e) (exp-cause e))
(($ set! var body) (exp-cause body))
(($ record bindings)
(foldr (lambda (x y)
(append (match x (($ bind _ e) (exp-cause e))) y))
'()
bindings))
(($ type _ exp) (exp-cause exp)))))
(define display-type tidy)
(define type
(lambda names
(if (null? names)
(for-each globaldef tree)
(for-each
(match-lambda
((? symbol? x)
(match (lookup? global-env x)
(#f (use-error "~a is not defined" x))
(ty (pretty-print
`(,x : ,(display-type (name-ty ty)))))))
((? number? n)
(let* ((ty (check-type (tree-unindex n)))
(type (display-type ty)))
(pretty-print `(,n : ,type))))
(_ (use-error
"arguments must be identifiers or CHECK numbers")))
names))))
(define localtype
(lambda names
(if (null? names)
(for-each localdef tree)
(for-each
(lambda (x) (localdef (find-global x)))
names))))
(define find-global
(lambda (name)
(let ((d (ormap (match-lambda
((and d ($ define x _))
(and (eq? name (name-name x)) d))
(_ #f))
tree)))
(unless d (use-error "~a is not defined" name))
d)))
(define globaldef
(lambda (e)
(match e
(($ define x _)
(let ((type (display-type (name-ty x))))
(pretty-print `(,(pname x) : ,type))))
(_ #f))))
(define localdef
(lambda (e) (pretty-print (expdef e))))
(define expdef
(let* ((show (lambda (x)
`(,(pname x) : ,(display-type (name-ty x)))))
(pbind (match-lambda
(($ bind x e) `(,(show x) ,(expdef e))))))
(match-lambda
(($ define x e)
(if (or (not x) (and (name? x) (not (name-name x))))
(expdef e)
`(define ,(show x) ,(expdef e))))
((? defstruct? d) (pdef d))
((? datatype? d) (pdef d))
(($ and exps) `(and ,@(maplr expdef exps)))
(($ app fun args)
`(,(expdef fun) ,@(maplr expdef args)))
(($ begin exps) `(begin ,@(maplr expdef exps)))
(($ const c _) (pconst c))
(($ if test then els)
`(if ,(expdef test) ,(expdef then) ,(expdef els)))
(($ lam params body)
`(lambda ,(map show params) ,@(expdef body)))
(($ vlam params rest body)
`(lambda ,(append (map show params) (show rest))
,@(expdef body)))
(($ let bindings body)
`(let ,(map pbind bindings) ,@(expdef body)))
(($ let* bindings body)
`(let* ,(map pbind bindings) ,@(expdef body)))
(($ letr bindings body)
`(letrec ,(map pbind bindings) ,@(expdef body)))
(($ body defs exps)
(let ((pdefs (maplr expdef defs)))
(append pdefs (maplr expdef exps))))
(($ record bindings)
`(record ,@(maplr pbind bindings)))
(($ field x e) `(field ,x ,(expdef e)))
(($ cast (ty . _) e) `(: ,ty ,(expdef e)))
(($ or exps) `(or ,@(maplr expdef exps)))
(($ delay e) `(delay ,(expdef e)))
(($ set! x body)
`(set! ,(pname x) ,(expdef body)))
(($ var x) (pname x))
(($ match e1 clauses)
(let* ((pclause
(match-lambda
(($ mclause p exp fail)
(if fail
`(,(expdef p) (=> ,(pname fail)) ,@(expdef exp))
`(,(expdef p) ,@(expdef exp))))))
(p1 (expdef e1)))
`(match ,p1 ,@(maplr pclause clauses))))
(($ pconst x _) (pconst x))
(($ pvar x) (show x))
(($ pany) '_)
(($ pelse) 'else)
(($ pnot pat) `(not ,(expdef pat)))
(($ pand pats) `(and ,@(maplr expdef pats)))
(($ ppred pred)
(match (pname pred)
('false-object? #f)
('true-object? #t)
('null? '())
(x `(? ,x))))
(($ pobj tag args)
(match (cons (pname tag) args)
(('pair? x y) (cons (expdef x) (expdef y)))
(('box? x) (box (expdef x)))
(('vector? . x) (list->vector (maplr expdef x)))
((tg . _)
`($ ,(strip-? tg) ,@(maplr expdef args)))))
(($ type _ exp) (expdef exp))
(($ check _ exp) (expdef exp)))))
(define check-type
(match-lambda
(($ type ty ($ check inf ($ var x))) ty)
(($ type ty ($ check inf ($ lam x e1))) ty)
(($ type ty ($ check inf ($ vlam x rest e1))) ty)
(($ type _ ($ check inf ($ app e1 args)))
(typeof e1))
(($ type _ ($ check inf ($ field x e1)))
(typeof e1))
(($ type _ ($ check inf ($ cast (x . _) e1)))
(typeof e1))
(($ type _ ($ check inf ($ match e1 clauses)))
(typeof e1))))
(define tree '())
(define global-env empty-env)
(define verbose #f)
(define times #t)
(define benchmarking #f)
(define cons-mutators '(set-car! set-cdr!))
(define st:check
(lambda args
(parameterize
((print-level #f)
(print-length #f)
(pretty-maximum-lines #f))
(let ((output (apply do-soft args)))
(when output
(printf
"Typed program written to file ~a~%"
output))))))
(define st:run
(lambda (file)
(parameterize
((optimize-level 3))
(when benchmarking
(printf "Reloading slow CHECKs...~%")
(load (string-append
installation-directory
"checklib.scm"))
(set! benchmarking #f))
(load file))))
(define st:bench
(lambda (file)
(parameterize
((optimize-level 3))
(unless
benchmarking
(unless
fastlibrary-file
(use-error
"No benchmarking mode in this version"))
(printf "Reloading fast CHECKs...~%")
(load (string-append
installation-directory
fastlibrary-file))
(set! benchmarking #t))
(load file))))
(define st:
(lambda args
(parameterize
((print-level #f)
(print-length #f)
(pretty-maximum-lines #f))
(let ((output (apply do-soft args)))
(cond ((not output)
(use-error "Output file name required to run"))
((= 0 n-unbound)
(printf
"Typed program written to file ~a, executing ...~%"
output)
(flush-output)
(st:run output))
(else
(printf
"Typed program written to file ~a, not executing (unbound refs)~%"
output)))))))
(define do-soft
(match-lambda*
((input (? string? output))
(when (strip-suffix output)
(use-error
"output file name cannot end in .ss or .scm"))
(cond ((string? input)
(soft-files (list input) output)
output)
((and (list? input) (andmap string? input))
(soft-files input output)
output)
(else (soft-def input output) output)))
((input #f)
(cond ((string? input) (soft-files (list input) #f) #f)
((and (list? input) (andmap string? input))
(soft-files input #f)
#f)
(else (soft-def input #f) #f)))
((input)
(cond ((string? input)
(let ((o (string-append
(or (strip-suffix input) input)
".soft")))
(soft-files (list input) o)
o))
((and (list? input) (andmap string? input))
(use-error "Output file name required"))
(else (soft-def input #t) #f)))
(else (use-error
"Input must be a file name or list of file names"))))
(define rawmode #f)
(define st:control
(lambda args
(let ((dbg (match-lambda
('raw
(set! display-type ptype)
(set! rawmode #t))
('!raw
(set! display-type tidy)
(set! rawmode #f))
('verbose (set! verbose #t))
('!verbose (set! verbose #f))
('times (set! times #t))
('!times (set! times #f))
('partial (set! fullsharing #f))
('!partial (set! fullsharing #t))
('pseudo (set! pseudo pseudo-subtype))
('!pseudo (set! pseudo #f))
('populated (set! populated #t))
('!populated (set! populated #f))
('matchst (set! matchst #t))
('!matchst (set! matchst #f))
('genmatch (set! genmatch #t))
('!genmatch (set! genmatch #f))
('letonce (set! letonce #t))
('!letonce (set! letonce #f))
('global-error (set! global-error #t))
('!global-error (set! global-error #f))
('share (set! share #t))
('!share (set! share #f))
('flags (set! flags #t))
('!flags (set! flags #f))
('depths (set! dump-depths #t))
('!depths (set! dump-depths #f))
('match (set! keep-match #t))
('!match (set! keep-match #f))
(x (printf "Error: unknown debug switch ~a~%" x)
(st:control)))))
(if (null? args)
(begin
(printf "Current values:")
(for-each
(lambda (x) (printf " ~a" x))
(show-controls))
(printf "~%"))
(for-each dbg args)))))
(define show-controls
(lambda ()
(list (if rawmode 'raw '!raw)
(if verbose 'verbose '!verbose)
(if times 'times '!times)
(if share 'share '!share)
(if flags 'flags '!flags)
(if dump-depths 'depths '!depths)
(if fullsharing '!partial 'partial)
(if pseudo 'pseudo '!pseudo)
(if populated 'populated '!populated)
(if letonce 'letonce '!letonce)
(if matchst 'matchst '!matchst)
(if genmatch 'genmatch '!genmatch)
(if global-error 'global-error '!global-error)
(if keep-match 'match '!match))))
(define soft-def
(lambda (exp output)
(reinit-macros!)
(reinit-types!)
(reinit-output!)
(set! visible-time 0)
(match-let*
((before-parse (cpu-time))
(defs (parse-def exp))
(before-bind (cpu-time))
((defs env tenv unbound)
(bind-defs
defs
initial-env
initial-type-env
'()
0))
(_ (warn-unbound unbound))
(_ (if cons-is-mutable
(printf
"Note: use of ~a, treating cons as MUTABLE~%"
cons-mutators)
(printf
"Note: no use of ~a, treating cons as immutable~%"
cons-mutators)))
(before-improve (cpu-time))
(defs (improve-defs defs))
(before-typecheck (cpu-time))
(_ (type-check defs))
(_ (set! global-env env))
(before-output (cpu-time))
(_ (check output))
(_ (print-summary ""))
(before-end (cpu-time)))
(when times
(printf
"~a seconds parsing,~%"
(exact->inexact
(* (- before-bind before-parse)
clock-granularity)))
(printf
"~a seconds binding,~%"
(exact->inexact
(* (- before-improve before-bind)
clock-granularity)))
(printf
"~a seconds improving,~%"
(exact->inexact
(* (- before-typecheck before-improve)
clock-granularity)))
(printf
"~a seconds type checking,~%"
(exact->inexact
(* (- (- before-output before-typecheck)
visible-time)
clock-granularity)))
(printf
"~a seconds setting visibility,~%"
(exact->inexact
(* visible-time clock-granularity)))
(printf
"~a seconds writing output,~%"
(exact->inexact
(* (- before-end before-output)
clock-granularity)))
(printf
"~a seconds in total.~%"
(exact->inexact
(* (- before-end before-parse) clock-granularity)))))))
(define type-check
(lambda (defs)
(set! tree defs)
(type-defs defs)
defs))
(define soft-files
(lambda (files output)
(let ((contents
(map (lambda (f) `(begin ,@(readfile f))) files)))
(soft-def `(begin ,@contents) output))))
(define strip-suffix
(lambda (name)
(let ((n (string-length name)))
(or (and (<= 3 n)
(equal? ".ss" (substring name (- n 3) n))
(substring name 0 (- n 3)))
(and (<= 4 n)
(equal? ".scm" (substring name (- n 4) n))
(substring name 0 (- n 4)))))))
(define st:deftype
(match-lambda*
(((? symbol? x) ? list? mutability)
(=> fail)
(if (andmap boolean? mutability)
(deftype x mutability)
(fail)))
(args (use-error
"Invalid command ~a"
`(st:deftype ,@args)))))
(define st:defprim
(match-lambda*
(((? symbol? x) type) (defprim x type 'impure))
(((? symbol? x) type (? symbol? mode))
(defprim x type mode))
(args (use-error
"Invalid command ~a"
`(st:defprim ,@args)))))
(define st:help
(lambda ()
(printf
"Commands for Soft Scheme (~a)~%"
st:version)
(printf
" (st: file (output)) type check file and execute~%")
(printf
" (st:type (name)) print types of global defs~%")
(printf
" (st:check file (output)) type check file~%")
(printf
" (st:run file) execute type checked file~%")
(printf
" (st:bench file) execute type checked file fast~%")
(printf
" (st:ltype (name)) print types of local defs~%")
(printf
" (st:cause) print cause of CHECKs~%")
(printf
" (st:summary) print summary of CHECKs~%")
(printf
" (st:help) prints this message~%")
(printf
" (st:defprim name type (mode)) define a new primitive~%")
(printf
" (st:deftype name bool ...) define a new type constructor~%")
(printf
" (st:control flag ...) set internal flags~%")
(printf
"For more info, see ftp://ftp.nj.nec.com/pub/wright/ssmanual/softscheme.html~%")
(printf
"Copyright (c) 1993, 1994, 1995 by Andrew K. Wright under the~%")
(printf
"terms of the Gnu Public License. No warranties of any kind apply.~%")))
(define st:type type)
(define st:ltype localtype)
(define st:cause cause)
(define st:summary
(lambda () (print-summary "")))
(define init!
(lambda ()
(when customization-file
(load (string-append
installation-directory
customization-file)))
(let ((softrc
(string-append home-directory "/.softschemerc")))
(when (file-exists? softrc) (load softrc)))
(set! global-env initial-env)
(st:help)))
(init!)
View git blame Copy permalink