diff --git a/doc/compiler.txt b/doc/compiler.txt new file mode 100644 index 0000000..348d60c --- /dev/null +++ b/doc/compiler.txt @@ -0,0 +1,96 @@ +(let ...) +(let* ...) +(letrec ...) + +; (if cond-expr true-expr false-expr) +; => (let ([cond-val cond-expr]) +; (let ([next-fn (%if cond-val +; (lambda () true-expr) +; (lambda () false-expr))]) +; (next-fn))) + +(define (transform-if form) + (define cond-val (gensym)) + (define next-fn (gensym)) + (define-values (cond-expr true-expr false-expr) + (apply values (cdr form))) + `(let ([,cond-val ,cond-expr]) + (let ([,next-fn (%if ,cond-val + (lambda () ,true-expr) + (lambda () ,false-expr))]) + (,next-fn)))) + +; (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 (transform-lambda-arglist 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 opt rst)) + (values nil arglist))) + (if (eq? arglist nil) + (values nil nil #f) + (if (pair? (car arglist)) + (let-values ([(opt rst) (split-optional arglist)]) + (values nil opt rst)) + (let-values ([(req opt rst) (split-arglist (cdr arglist))]) + (values (cons (car arglist) req) opt rst))))) + + (define-values (requireds optionals rest) (split-arglist arglist)) + (define argv-temp (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 (eq? ,argv-temp nil) + (set! ,(car opt-list) ,(cdr opt-list)) + (set! ,(car opt-list) (car ,argv-temp))) + ,inner)) + (define rest+bodyexprs (if rest `(let ([,rest ,argv-temp]) ,@bodyexprs) + `(begin ,@bodyexprs))) + `(lambda ,argv-temp + ,(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 (transform-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)) + `(let ([,fn-var ,fn-expr] ,@arg-vars ,argv) + ,@(map (lambda (x y) `(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)))