297 lines
11 KiB
Scheme
Executable File
297 lines
11 KiB
Scheme
Executable File
#! /usr/bin/mzscheme
|
|
#lang scheme
|
|
|
|
(define (simplify-form form)
|
|
(if (pair? form)
|
|
(case (car form)
|
|
[(let) (simplify-let form)]
|
|
[(let*) (simplify-let* form)]
|
|
[(letrec) (simplify-letrec form)]
|
|
[(if) (simplify-if form)]
|
|
[(lambda) (simplify-lambda form)]
|
|
[(begin) `(%bind () ,@(map simplify-form (cdr form)))]
|
|
[(set!) (simplify-set! form)]
|
|
[(car cdr cons) (simplify-primitive (case (first form)
|
|
[(car) '%car]
|
|
[(cdr) '%cdr]
|
|
[(cons) '%cons])
|
|
(cdr form))]
|
|
[(%bind %if %tail-call %apply %lambda %set! %cons %car %cdr) form]
|
|
[else (simplify-funcall form)])
|
|
form))
|
|
|
|
(define (simplify-set! form)
|
|
(let ([value-form (simplify-form (third form))])
|
|
(if (and (pair? value-form) (eq? (first value-form) '%bind))
|
|
`(%bind ,(second value-form)
|
|
,@(foldr (lambda (x s)
|
|
(if (pair? s)
|
|
(cons x s)
|
|
(list (simplify-set! `(set! ,(second form) ,x)))))
|
|
'()
|
|
(cddr value-form)))
|
|
`(%set! ,(second form) ,value-form))))
|
|
|
|
(define (simplify-primitive new-id value-forms)
|
|
(define bindings (map (lambda (vf)
|
|
(if (pair? vf)
|
|
(list (gensym) vf)
|
|
(list vf vf)))
|
|
value-forms))
|
|
(define temp-bindings (filter (lambda (x) (not (eq? (first x) (second x))))
|
|
bindings))
|
|
|
|
`(%bind ,(map first temp-bindings)
|
|
,@(map (lambda (x) (simplify-set! `(set! ,(first x) ,(second x)))) temp-bindings)
|
|
(,new-id ,@(map first bindings))))
|
|
|
|
; (let ([var expr]...) bodyexpr...) ; first eval exprs, then assign bindings in parallel
|
|
; => (%bind (tmp...)
|
|
; (%set! tmp ,(simplify-form expr))...
|
|
; (%bind (var...)
|
|
; (%set! var tmp)...
|
|
; bodyexpr...))
|
|
|
|
(define (simplify-let form)
|
|
(define bindings (second form))
|
|
(define bodyexprs (cdr (cdr form)))
|
|
(define vars (map (lambda (x) (if (pair? x) (first x) x)) bindings))
|
|
(define temp-bindings
|
|
(append-map
|
|
(lambda (x) (if (pair? x)
|
|
(let ([tmp (gensym)])
|
|
`((,tmp
|
|
,(simplify-form `(set! ,tmp ,(second x)))
|
|
(%set! ,(first x) ,tmp))))
|
|
'()))
|
|
bindings))
|
|
(if (pair? bindings)
|
|
(if (pair? (cdr bindings))
|
|
`(%bind ,(map first temp-bindings)
|
|
,@(map second temp-bindings)
|
|
(%bind ,vars
|
|
,@(map third temp-bindings)
|
|
,@(map simplify-form bodyexprs)))
|
|
`(%bind (,(first vars))
|
|
,@(if (pair? (first bindings))
|
|
`(,(simplify-form `(set! ,(first vars) ,(second (first bindings)))))
|
|
'())
|
|
,@(map simplify-form bodyexprs)))
|
|
`(%bind () ,@bodyexprs)))
|
|
|
|
; (let* ...) ; eval exprs & bind variables serially
|
|
; => (let ([var-0 expr-0])
|
|
; (let ([var-1 expr-1])
|
|
; (...
|
|
; bodyexprs...)))
|
|
|
|
(define (simplify-let* form)
|
|
(define bindings (second form))
|
|
(define bodyexprs (cdr (cdr form)))
|
|
(define (add-binding bind bodyexpr)
|
|
`(let (,bind) ,bodyexpr))
|
|
(simplify-form (foldr add-binding `(begin ,@bodyexprs) bindings)))
|
|
|
|
; (letrec ...) ; init bindings to undefined, then assign values in series
|
|
; => (let (var...)
|
|
; (set! var expr)...
|
|
; bodyexprs)
|
|
|
|
(define (simplify-letrec form)
|
|
(define bindings (second form))
|
|
(define bodyexprs (cdr (cdr form)))
|
|
(simplify-form
|
|
`(%bind (,@(map (lambda (x) (if (pair? x) (first x) x)) bindings))
|
|
,@(append-map
|
|
(lambda (x)
|
|
(if (pair? x)
|
|
`((set! ,(first x) ,(simplify-form (second x))))
|
|
'()))
|
|
bindings)
|
|
,@(map simplify-form bodyexprs))))
|
|
|
|
(define (simplify-if form)
|
|
(define cond-val (gensym))
|
|
(define next-fn (gensym))
|
|
(define true-fn (gensym))
|
|
(define false-fn (gensym))
|
|
(define-values (cond-expr true-expr false-expr)
|
|
(apply values (cdr form)))
|
|
(simplify-form
|
|
`(let ([,cond-val ,cond-expr]
|
|
[,true-fn (lambda () ,true-expr)]
|
|
[,false-fn (lambda () ,false-expr)])
|
|
(let ([,next-fn (%if ,cond-val ,true-fn ,false-fn)])
|
|
(%apply ,next-fn %nil)))))
|
|
|
|
; (lambda (required... [optional default-expr]... . rest) bodyexpr...)
|
|
; => (lambda argv
|
|
; (let ([argv-temp argv])
|
|
; (let ([required-0 (car argv-temp)])
|
|
; (set! argv-temp (cdr argv-temp)))
|
|
; (let ([required-1 (car argv-temp)])
|
|
; (set! argv-temp (cdr argv-temp)))
|
|
; (...
|
|
; (let (optional-0)
|
|
; (if (eq? argv-temp %nil)
|
|
; (set! optional-0 default-expr-0)
|
|
; (set! optional-0 (car argv-temp)))
|
|
; (set! argv-temp (cdr argv-temp))
|
|
; (let (optional-1)
|
|
; (if (eq? argv-temp %nil)
|
|
; (set! optional-1 default-expr-1)
|
|
; (set! optional-1 (car argv-temp)))
|
|
; (set! argv-temp (cdr argv-temp))
|
|
; (...
|
|
; (let ([rest argv-temp])
|
|
; bodyexpr...)...)))...)))
|
|
|
|
(define (simplify-lambda form)
|
|
(define arglist (car (cdr form)))
|
|
(define bodyexprs (cdr (cdr form)))
|
|
(define (split-arglist arglist)
|
|
(define (split-optional arglist)
|
|
(if (pair? arglist)
|
|
(let-values ([(opt rst) (split-optional (cdr arglist))])
|
|
(values (cons (car arglist) opt) rst))
|
|
(values '() arglist)))
|
|
(if (pair? arglist)
|
|
(if (pair? (car arglist))
|
|
(let-values ([(opt rst) (split-optional arglist)])
|
|
(values '() opt rst))
|
|
(let-values ([(req opt rst) (split-arglist (cdr arglist))])
|
|
(values (cons (car arglist) req) opt rst)))
|
|
(values '() '() #f)))
|
|
|
|
(define-values (requireds optionals rest) (split-arglist arglist))
|
|
(define argv-temp (gensym))
|
|
(define k (gensym))
|
|
(define rval (gensym))
|
|
|
|
(define (add-req req inner) `(let ([,req (car ,argv-temp)])
|
|
(set! ,argv-temp (cdr ,argv-temp))
|
|
,inner))
|
|
(define (add-opt opt-list inner) `(let (,(car opt-list))
|
|
(if (pair? ,argv-temp)
|
|
(begin
|
|
(set! ,(first opt-list) (car ,argv-temp))
|
|
(set! ,argv-temp (cdr ,argv-temp)))
|
|
(set! ,(first opt-list) ,(second opt-list)))
|
|
,inner))
|
|
(define rest+bodyexprs (if rest `(let ([,rest ,argv-temp]) ,@bodyexprs)
|
|
`(begin ,@bodyexprs)))
|
|
(define (add-tail-call k rval bind)
|
|
`(%bind ,(second bind)
|
|
,@(foldr (lambda (subform after)
|
|
(if (pair? after)
|
|
(cons subform after)
|
|
(if (and (pair? subform)
|
|
(eq? (first subform) '%set!)
|
|
(eq? (second subform) rval)
|
|
(pair? (third subform))
|
|
(eq? (first (third subform)) '%apply))
|
|
(let ([fn (second (third subform))]
|
|
[argv (third (third subform))])
|
|
`((%tail-call ,fn ,argv ,k)))
|
|
`((%set! ,rval (%cons ,rval %nil))
|
|
(%tail-call ,k ,rval #f)))))
|
|
'()
|
|
(cddr bind))))
|
|
`(%lambda
|
|
,(add-tail-call k rval
|
|
(flatten-binds
|
|
`(%bind (,rval ,k)
|
|
(%set! ,k %k)
|
|
,(make-bindings-unique
|
|
(simplify-form
|
|
`(set! ,rval (let ([,argv-temp %argv])
|
|
,(foldr add-req
|
|
(foldr add-opt
|
|
rest+bodyexprs
|
|
optionals)
|
|
requireds))))))))))
|
|
|
|
; (fn-expr arg-expr...)
|
|
; => (let ([fn-var fn-expr] arg-var... argv)
|
|
; (set! fn-var fn-expr)
|
|
; (set! arg-var arg-expr)...
|
|
; (set! argv %nil)
|
|
; (set! argv (cons arg-var argv))... [reversed]
|
|
; (%apply fn-var argv))
|
|
|
|
(define (simplify-funcall form)
|
|
(define fn-expr (car form))
|
|
(define arg-exprs (cdr form))
|
|
(define fn-var (gensym))
|
|
(define arg-vars (map (lambda (x) (gensym)) arg-exprs))
|
|
(define argv (gensym))
|
|
(simplify-form
|
|
`(%bind (,fn-var ,@arg-vars ,argv)
|
|
,(simplify-form `(set! ,fn-var ,fn-expr))
|
|
,@(map (lambda (x y) (simplify-form `(set! ,x ,y))) arg-vars arg-exprs)
|
|
(%set! ,argv %nil)
|
|
,@(reverse (map (lambda (x) `(%set! ,argv (%cons ,x ,argv))) arg-vars))
|
|
(%apply ,fn-var ,argv))))
|
|
|
|
(define (subst-var old-var new-var form)
|
|
(define (recurse form)
|
|
(subst-var old-var new-var form))
|
|
(if (pair? form)
|
|
(case (car form)
|
|
[(%bind)
|
|
(if (memq old-var (second form))
|
|
form
|
|
`(%bind ,(second form) ,@(map recurse (cddr form))))]
|
|
[(%if %tail-call %apply %lambda %set! %cons %car %cdr)
|
|
`(,(first form) ,@(map recurse (cdr form)))]
|
|
[else (error "Unsimplified form:" form)])
|
|
(if (eq? form old-var)
|
|
new-var
|
|
form)))
|
|
|
|
(define (make-bindings-unique form)
|
|
(if (pair? form)
|
|
(case (car form)
|
|
[(%bind)
|
|
(let ([new-vars (map (lambda _ (gensym)) (second form))])
|
|
`(%bind ,new-vars
|
|
,@(map (lambda (frm)
|
|
(foldl (lambda (pair s)
|
|
(subst-var (car pair)
|
|
(cdr pair)
|
|
s))
|
|
(make-bindings-unique frm)
|
|
(map cons (second form) new-vars)))
|
|
(cddr form))))]
|
|
[(%if %tail-call %apply %lambda %set! %cons %car %cdr) form]
|
|
[else (error "Unsimplified form:" form)])
|
|
form))
|
|
|
|
(define (flatten-binds form)
|
|
;(pretty-print form) (write-char #\Newline)
|
|
(if (pair? form)
|
|
(case (car form)
|
|
[(%bind)
|
|
(let* ([bound-vars (second form)]
|
|
[subforms (append-map (lambda (form)
|
|
(let ([new-form (flatten-binds form)])
|
|
(if (and (pair? new-form) (eq? (car new-form) '%bind))
|
|
(begin
|
|
(set! bound-vars (append bound-vars (second new-form)))
|
|
(cddr new-form))
|
|
(list new-form))))
|
|
(cddr form))])
|
|
`(%bind ,bound-vars ,@subforms))]
|
|
[(%if %tail-call %apply %set! %lambda %cons %car %cdr) form]
|
|
[else (error "Unsimplified form:" form)])
|
|
form))
|
|
|
|
(define (compile form)
|
|
(flatten-binds
|
|
(make-bindings-unique
|
|
(simplify-form `(lambda () ,form)))))
|
|
|
|
(pretty-print (compile (read)))
|
|
|
|
; vim:set sw=2 expandtab:
|