111 lines
3.9 KiB
Scheme
111 lines
3.9 KiB
Scheme
#lang scheme/base
|
|
|
|
(require scheme/list)
|
|
(require (file "utilities.scm"))
|
|
(require (file "primitives.scm"))
|
|
|
|
(provide map-variables)
|
|
|
|
(define (special-constant? sym)
|
|
(memq sym '(#%f #%nil #%undef)))
|
|
|
|
(define (lambda-value? form)
|
|
(and (pair? form) (eq? (first form) '#%lambda)))
|
|
|
|
(define (lookup fst lst)
|
|
(ormap (lambda (x)
|
|
(and (eq? (first x) fst)
|
|
(second x)))
|
|
lst))
|
|
|
|
(define (from-list lst (end-fn (lambda () #f)))
|
|
(lambda ()
|
|
(if (pair? lst)
|
|
(let ([next (first lst)])
|
|
(set! lst (cdr lst))
|
|
next)
|
|
(end-fn))))
|
|
|
|
(define (map-variables lambda/template-form (capture-map '()))
|
|
(let ([bind (fourth lambda/template-form)]
|
|
[next-g-var (from-list global-variables)]
|
|
[next-i-var (from-list instance-variables)]
|
|
[next-t-var (from-list transient-variables)]
|
|
[gvar-map '()]
|
|
[ivar-map '()]
|
|
[var-map '()])
|
|
|
|
(define (add-g-var value)
|
|
(cond
|
|
[(special-constant? value) value]
|
|
[(or (eq? value #f) (equal? value '(quote #f))) '#%f]
|
|
[(equal? value '(quote ())) '#%nil]
|
|
[else
|
|
(let ([value (cond [(and (pair? value) (eq? (first value) 'quote)) (second value)]
|
|
[(symbol? value) `(#%builtin ,(symbol->string value))]
|
|
[else value])])
|
|
(or (lookup value gvar-map)
|
|
(let ([g-var (next-g-var)])
|
|
(set! gvar-map (cons (list value g-var) gvar-map))
|
|
g-var)))]))
|
|
|
|
(define (add-i-var source)
|
|
(or (and (special-constant? source) source)
|
|
(lookup source ivar-map)
|
|
(let ([i-var (next-i-var)])
|
|
(set! ivar-map (cons (list source i-var) ivar-map))
|
|
i-var)))
|
|
|
|
(let ([exprs '()])
|
|
(define (add-var var mvar)
|
|
(when var
|
|
(set! var-map
|
|
(cons (list var mvar)
|
|
(filter (lambda (x) (not (eq? (first x) var)))
|
|
var-map)))))
|
|
|
|
(define (add-expr var val)
|
|
(let ([tvar (next-t-var)])
|
|
(set! exprs (cons `(#%set! ,tvar ,val) exprs))
|
|
(add-var var tvar)))
|
|
|
|
(for ([bound-var (in-list (second bind))])
|
|
(add-var bound-var '#%undef))
|
|
|
|
(for ([free-var (in-list (free-variables bind))])
|
|
(let ([capt (lookup free-var capture-map)])
|
|
(when capt (add-var free-var (add-i-var capt)))))
|
|
|
|
(for ([expr (in-list (cddr bind))])
|
|
(let* ([setexpr? (and (pair? expr) (eq? (first expr) '#%set!))]
|
|
[var (if setexpr? (second expr) #f)]
|
|
[val (if setexpr? (third expr) expr)])
|
|
(cond [(lambda-value? val)
|
|
(let ([newval (map-variables val var-map)])
|
|
(if (eq? (first newval) '#%lambda)
|
|
(add-var var (add-g-var newval))
|
|
(add-expr var `(#%make-lambda ,(add-g-var newval)))))]
|
|
[(literal-value? val)
|
|
(add-var var (add-g-var val))]
|
|
[(not (symbol? val))
|
|
(add-expr var (map-form val
|
|
#:variable (lambda (recurse kind form)
|
|
(or (and (machine-variable? form) form)
|
|
(lookup form var-map)
|
|
(add-g-var form)))
|
|
#:literal (lambda (recurse kind form)
|
|
(add-g-var form))))]
|
|
[else
|
|
(add-var var (or (and (machine-variable? val) val)
|
|
(lookup val var-map)
|
|
(add-g-var val)))])))
|
|
|
|
(set! bind `(#%bind () ,@(reverse exprs))))
|
|
|
|
`(,(if (null? ivar-map) '#%lambda '#%template)
|
|
,(map first (reverse gvar-map))
|
|
,(map first (reverse ivar-map))
|
|
,bind)))
|
|
|
|
; vim:set sw=2 expandtab:
|