119 lines
4.8 KiB
Racket
119 lines
4.8 KiB
Racket
#lang racket/base
|
|
(require (for-template racket/base)
|
|
syntax/kerncase
|
|
racket/list
|
|
racket/contract
|
|
(for-template "abort-resume.rkt")
|
|
"util.rkt")
|
|
(provide/contract
|
|
[elim-letrec ((listof syntax?) . -> . (syntax? . -> . syntax?))]
|
|
[elim-letrec-term (syntax? . -> . syntax?)])
|
|
|
|
; elim-letrec : (listof identifier-syntax?)[3] -> syntax?[2] -> syntax?[3]
|
|
; Eliminates letrec-values from syntax[2] and correctly handles references to
|
|
; letrec-bound variables [3] therein.
|
|
(define ((elim-letrec ids) stx)
|
|
(recertify
|
|
stx
|
|
(kernel-syntax-case
|
|
stx (transformer?)
|
|
[(begin be ...)
|
|
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
|
|
(syntax/loc stx
|
|
(begin be ...)))]
|
|
[(begin0 be ...)
|
|
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
|
|
(syntax/loc stx
|
|
(begin0 be ...)))]
|
|
[(set! v ve)
|
|
(with-syntax ([ve ((elim-letrec ids) #'ve)])
|
|
(if (bound-identifier-member? #'id ids)
|
|
(syntax/loc stx (#%plain-app set-box! id ve))
|
|
(syntax/loc stx (set! id ve))))]
|
|
[(let-values ([(v ...) ve] ...) be ...)
|
|
(with-syntax ([(ve ...) (map (elim-letrec ids) (syntax->list #'(ve ...)))]
|
|
[(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
|
|
(syntax/loc stx
|
|
(let-values ([(v ...) ve] ...) be ...)))]
|
|
[(letrec-values ([(v ...) ve] ...) be ...)
|
|
(let ([new-ids (apply append ids (map syntax->list (syntax->list #'((v ...) ...))))]
|
|
[gfss (map (lambda (vs)
|
|
(map (lambda (v)
|
|
(define-values (v-def v-ref) (generate-formal (syntax->datum v) v))
|
|
(cons v-def v-ref))
|
|
(syntax->list vs)))
|
|
(syntax->list #'((v ...) ...)))])
|
|
(with-syntax
|
|
([((nv-def ...) ...)
|
|
(map (lambda (gfs) (map car gfs)) gfss)]
|
|
[((nv-ref ...) ...)
|
|
(map (lambda (gfs) (map cdr gfs)) gfss)]
|
|
[((nv-box ...) ...) (map (lambda (nvs)
|
|
(map (lambda (x) (syntax/loc x (#%plain-app box the-undef)))
|
|
(syntax->list nvs)))
|
|
(syntax->list #`((v ...) ...)))]
|
|
[(ve ...) (map (elim-letrec new-ids) (syntax->list #'(ve ...)))]
|
|
[(be ...) (map (elim-letrec new-ids) (syntax->list #'(be ...)))])
|
|
(syntax/loc stx
|
|
(let-values ([(v ...)
|
|
(#%plain-app values nv-box ...)] ...)
|
|
(begin (#%plain-app call-with-values
|
|
(#%plain-lambda () ve)
|
|
(#%plain-lambda
|
|
(nv-def ...)
|
|
(#%plain-app set-box! v nv-ref) ...))
|
|
...
|
|
be ...)))))]
|
|
[(#%plain-lambda formals be ...)
|
|
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
|
|
(syntax/loc stx
|
|
(#%plain-lambda formals be ...)))]
|
|
[(case-lambda [formals be] ...)
|
|
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
|
|
(syntax/loc stx
|
|
(case-lambda [formals be] ...)))]
|
|
[(case-lambda [formals be ...] ...)
|
|
((elim-letrec ids)
|
|
(syntax/loc stx
|
|
(case-lambda [formals (begin be ...)] ...)))]
|
|
[(if te ce ae)
|
|
(with-syntax ([te ((elim-letrec ids) #'te)]
|
|
[ce ((elim-letrec ids) #'ce)]
|
|
[ae ((elim-letrec ids) #'ae)])
|
|
(syntax/loc stx
|
|
(if te ce ae)))]
|
|
[(quote datum)
|
|
stx]
|
|
[(quote-syntax datum)
|
|
stx]
|
|
[(with-continuation-mark ke me be)
|
|
(with-syntax ([ke ((elim-letrec ids) #'ke)]
|
|
[me ((elim-letrec ids) #'me)]
|
|
[be ((elim-letrec ids) #'be)])
|
|
(syntax/loc stx
|
|
(with-continuation-mark ke me be)))]
|
|
[(#%plain-app e ...)
|
|
(with-syntax ([(e ...) (map (elim-letrec ids) (syntax->list #'(e ...)))])
|
|
(syntax/loc stx
|
|
(#%plain-app e ...)))]
|
|
[(#%top . v)
|
|
stx]
|
|
[(#%variable-reference . v)
|
|
stx]
|
|
[id (identifier? #'id)
|
|
(if (bound-identifier-member? #'id ids)
|
|
(syntax/loc stx (#%plain-app unbox id))
|
|
#'id)]
|
|
[(letrec-syntaxes+values ([(sv ...) se] ...)
|
|
([(vv ...) ve] ...)
|
|
be ...)
|
|
((elim-letrec ids)
|
|
(syntax/loc stx
|
|
(letrec-values ([(vv ...) ve] ...) be ...)))]
|
|
[(#%expression d)
|
|
(quasisyntax/loc stx (#%expression #,((elim-letrec ids) #'d)))]
|
|
[_
|
|
(raise-syntax-error 'elim-letrec "Dropped through:" stx)])))
|
|
|
|
(define elim-letrec-term (elim-letrec empty))
|