suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Transformer environment

Browse Source 
svn: r6662
This commit is contained in:
Jay McCarthy 2007-06-14 18:46:04 +00:00
parent 238fdc9955
commit ae43910cd7
7 changed files with 65 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/web-server/lang/anormal.ss
View File

@ -34,7 +34,7 @@
(recertify (recertify
stx stx
(kernel-syntax-case (kernel-syntax-case
stx #f stx (transformer?)
[(begin) [(begin)
(anormal ctxt (syntax/loc stx (#%app (#%top . void))))] (anormal ctxt (syntax/loc stx (#%app (#%top . void))))]
[(begin lbe) [(begin lbe)
@ -64,13 +64,15 @@
(syntax/loc stx (syntax/loc stx
(define-values (v ...) ve)))] (define-values (v ...) ve)))]
[(define-syntaxes (v ...) ve) [(define-syntaxes (v ...) ve)
(with-syntax ([ve (anormal-term #'ve)]) (parameterize ([transformer? #t])
(syntax/loc stx (with-syntax ([ve (anormal-term #'ve)])
(define-values (v ...) ve)))] (syntax/loc stx
(define-syntaxes (v ...) ve))))]
[(define-values-for-syntax (v ...) ve) [(define-values-for-syntax (v ...) ve)
(with-syntax ([ve (anormal-term #'ve)]) (parameterize ([transformer? #t])
(syntax/loc stx (with-syntax ([ve (anormal-term #'ve)])
(define-values-for-syntax (v ...) ve)))] (syntax/loc stx
(define-values-for-syntax (v ...) ve))))]
[(set! v ve) [(set! v ve)
(anormal (anormal
(compose ctxt (compose ctxt

16
collects/web-server/lang/defun.ss
View File

@ -19,7 +19,7 @@
stx stx
(lambda () (lambda ()
(kernel-syntax-case (kernel-syntax-case
stx #f stx (transformer?)
[(begin be ...) [(begin be ...)
(let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))]) (let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))])
(values (quasisyntax/loc stx (begin #,@nbes)) (values (quasisyntax/loc stx (begin #,@nbes))
@ -33,13 +33,15 @@
(values (quasisyntax/loc stx (define-values (v ...) #,nve)) (values (quasisyntax/loc stx (define-values (v ...) #,nve))
defs))] defs))]
[(define-syntaxes (v ...) ve) [(define-syntaxes (v ...) ve)
(let-values ([(nve defs) (defun #'ve)]) (parameterize ([transformer? #t])
(values (quasisyntax/loc stx (define-syntaxes (v ...) #,nve)) (let-values ([(nve defs) (defun #'ve)])
defs))] (values (quasisyntax/loc stx (define-syntaxes (v ...) #,nve))
defs)))]
[(define-values-for-syntax (v ...) ve) [(define-values-for-syntax (v ...) ve)
(let-values ([(nve defs) (defun #'ve)]) (parameterize ([transformer? #t])
(values (quasisyntax/loc stx (define-values-for-syntax (v ...) #,nve)) (let-values ([(nve defs) (defun #'ve)])
defs))] (values (quasisyntax/loc stx (define-values-for-syntax (v ...) #,nve))
defs)))]
[(set! v ve) [(set! v ve)
(let-values ([(nve defs) (defun #'ve)]) (let-values ([(nve defs) (defun #'ve)])
(values (quasisyntax/loc stx (set! v #,nve)) (values (quasisyntax/loc stx (set! v #,nve))

16
collects/web-server/lang/elim-callcc.ss
View File

@ -32,7 +32,7 @@
(recertify (recertify
stx stx
(kernel-syntax-case* (kernel-syntax-case*
stx #f (call/cc call-with-values) stx (transformer?) (call/cc call-with-values)
[(begin be ...) [(begin be ...)
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
[(begin0 be ...) [(begin0 be ...)
@ -42,13 +42,15 @@
(syntax/loc stx (syntax/loc stx
(define-values (v ...) ve)))] (define-values (v ...) ve)))]
[(define-syntaxes (v ...) ve) [(define-syntaxes (v ...) ve)
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))]) (parameterize ([transformer? #t])
(syntax/loc stx (with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
(define-values (v ...) ve)))] (syntax/loc stx
(define-values (v ...) ve))))]
[(define-values-for-syntax (v ...) ve) [(define-values-for-syntax (v ...) ve)
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))]) (parameterize ([transformer? #t])
(syntax/loc stx (with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
(define-values-for-syntax (v ...) ve)))] (syntax/loc stx
(define-values-for-syntax (v ...) ve))))]
[(set! v ve) [(set! v ve)
(with-syntax ([ve (elim-callcc #'ve)]) (with-syntax ([ve (elim-callcc #'ve)])
(syntax/loc stx (set! v ve)))] (syntax/loc stx (set! v ve)))]

16
collects/web-server/lang/elim-letrec.ss
View File

@ -14,7 +14,7 @@
(recertify (recertify
stx stx
(kernel-syntax-case (kernel-syntax-case
stx #f stx (transformer?)
[(begin be ...) [(begin be ...)
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))]) (with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
(syntax/loc stx (syntax/loc stx
@ -28,13 +28,15 @@
(syntax/loc stx (syntax/loc stx
(define-values (v ...) ve)))] (define-values (v ...) ve)))]
[(define-syntaxes (v ...) ve) [(define-syntaxes (v ...) ve)
(with-syntax ([ve ((elim-letrec ids) #'ve)]) (parameterize ([transformer? #t])
(syntax/loc stx (with-syntax ([ve ((elim-letrec ids) #'ve)])
(define-syntaxes (v ...) ve)))] (syntax/loc stx
(define-syntaxes (v ...) ve))))]
[(define-values-for-syntax (v ...) ve) [(define-values-for-syntax (v ...) ve)
(with-syntax ([ve ((elim-letrec ids) #'ve)]) (parameterize ([transformer? #t])
(syntax/loc stx (with-syntax ([ve ((elim-letrec ids) #'ve)])
(define-values-for-syntax (v ...) ve)))] (syntax/loc stx
(define-values-for-syntax (v ...) ve))))]
[(set! v ve) [(set! v ve)
(with-syntax ([ve ((elim-letrec ids) #'ve)]) (with-syntax ([ve ((elim-letrec ids) #'ve)])
(if (bound-identifier-member? #'id ids) (if (bound-identifier-member? #'id ids)

12
collects/web-server/lang/freevars.ss
View File

@ -12,7 +12,7 @@
;; Find the free variables in an expression ;; Find the free variables in an expression
(define (free-vars stx) (define (free-vars stx)
(kernel-syntax-case (kernel-syntax-case
stx #f stx (transformer?)
[(begin be ...) [(begin be ...)
(free-vars* (syntax->list #'(be ...)))] (free-vars* (syntax->list #'(be ...)))]
[(begin0 be ...) [(begin0 be ...)
@ -21,11 +21,13 @@
(set-diff (free-vars #'ve) (set-diff (free-vars #'ve)
(syntax->list #'(v ...)))] (syntax->list #'(v ...)))]
[(define-syntaxes (v ...) ve) [(define-syntaxes (v ...) ve)
(set-diff (free-vars #'ve) (parameterize ([transformer? #t])
(syntax->list #'(v ...)))] (set-diff (free-vars #'ve)
(syntax->list #'(v ...))))]
[(define-values-for-syntax (v ...) ve) [(define-values-for-syntax (v ...) ve)
(set-diff (free-vars #'ve) (parameterize ([transformer? #t])
(syntax->list #'(v ...)))] (set-diff (free-vars #'ve)
(syntax->list #'(v ...))))]
[(set! v ve) [(set! v ve)
(free-vars #'ve)] (free-vars #'ve)]
[(let-values ([(v ...) ve] ...) be ...) [(let-values ([(v ...) ve] ...) be ...)

32
collects/web-server/lang/util.ss
View File

@ -4,6 +4,8 @@
(lib "list.ss")) (lib "list.ss"))
(provide (all-defined-except template)) (provide (all-defined-except template))
(define transformer? (make-parameter #f))
(define (recertify old-expr expr) (define (recertify old-expr expr)
(syntax-recertify expr old-expr (current-code-inspector) #f)) (syntax-recertify expr old-expr (current-code-inspector) #f))
@ -50,13 +52,15 @@
(syntax/loc stx (syntax/loc stx
(define-values (v ...) ve)))] (define-values (v ...) ve)))]
[(define-syntaxes (v ...) ve) [(define-syntaxes (v ...) ve)
(with-syntax ([ve (inner #'ve)]) (parameterize ([transformer? #t])
(syntax/loc stx (with-syntax ([ve (inner #'ve)])
(define-syntaxes (v ...) ve)))] (syntax/loc stx
(define-syntaxes (v ...) ve))))]
[(define-values-for-syntax (v ...) ve) [(define-values-for-syntax (v ...) ve)
(with-syntax ([ve (inner #'ve)]) (parameterize ([transformer? #t])
(syntax/loc stx (with-syntax ([ve (inner #'ve)])
(define-values-for-syntax (v ...) ve)))] (syntax/loc stx
(define-values-for-syntax (v ...) ve))))]
[_ [_
(raise-syntax-error 'define-case "Dropped through:" stx)]))) (raise-syntax-error 'define-case "Dropped through:" stx)])))
@ -126,7 +130,7 @@
(recertify (recertify
stx stx
(kernel-syntax-case (kernel-syntax-case
stx #f stx (transformer?)
[(begin be ...) [(begin be ...)
(with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
(syntax/loc stx (syntax/loc stx
@ -140,13 +144,15 @@
(syntax/loc stx (syntax/loc stx
(define-values (v ...) ve)))] (define-values (v ...) ve)))]
[(define-syntaxes (v ...) ve) [(define-syntaxes (v ...) ve)
(with-syntax ([ve (template #'ve)]) (parameterize ([transformer? #t])
(syntax/loc stx (with-syntax ([ve (template #'ve)])
(define-values (v ...) ve)))] (syntax/loc stx
(define-values (v ...) ve))))]
[(define-values-for-syntax (v ...) ve) [(define-values-for-syntax (v ...) ve)
(with-syntax ([ve (template #'ve)]) (parameterize ([transformer? #t])
(syntax/loc stx (with-syntax ([ve (template #'ve)])
(define-values-for-syntax (v ...) ve)))] (syntax/loc stx
(define-values-for-syntax (v ...) ve))))]
[(set! v ve) [(set! v ve)
(with-syntax ([ve (template #'ve)]) (with-syntax ([ve (template #'ve)])
(syntax/loc stx (syntax/loc stx

4
collects/web-server/tests/lang/anormal-test.ss
View File

@ -330,4 +330,6 @@
[(zero? (car l)) (k 0)] [(zero? (car l)) (k 0)]
[else [else
(* (car l) (cdr l))]))))) (* (car l) (cdr l))])))))
#t))))))) #t)))
(test-not-exn "define-struct" (lambda () (normalize-term (expand (syntax (define-struct posn (x y)))))))))))