97 lines
3.8 KiB
Plaintext
97 lines
3.8 KiB
Plaintext
(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)))
|