1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
#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)
(rearm
stx
(kernel-syntax-case
(disarm 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! id 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))
stx)]
[(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))
|
