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

fixing syntax issues

Browse Source 
svn: r9021
This commit is contained in:
Jay McCarthy 2008-03-18 20:04:28 +00:00
parent 407e0bc2d9
commit d1fac38565
6 changed files with 42 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -141,12 +141,10 @@
(ctxt stx)]
[id (identifier? #'id)
(ctxt #'id)]
; XXX Shouldn't be here
[(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)
(anormal ctxt
(elim-letrec-term stx))]
(anormal ctxt (elim-letrec-term stx))]
[(#%expression d)
(anormal
(ccompose ctxt

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

@ -88,32 +88,12 @@
(if (bound-identifier-member? #'id ids)
(syntax/loc stx (#%plain-app unbox id))
#'id)]
; XXX These two cases shouldn't be here.
[(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)
(let ([new-ids (apply append ids (map syntax->list (syntax->list #'((vv ...) ...))))])
(with-syntax ([((nvv ...) ...) (map (compose generate-temporaries syntax->list) (syntax->list #'((vv ...) ...)))]
[((nvv-box ...) ...) (map (lambda (nvs)
(map (lambda (x) (syntax/loc x (#%plain-app box the-undef)))
(syntax->list nvs)))
(syntax->list #`((vv ...) ...)))]
[(se ...) (map (elim-letrec new-ids) (syntax->list #'(se ...)))]
[(ve ...) (map (elim-letrec new-ids) (syntax->list #'(ve ...)))]
[(be ...) (map (elim-letrec new-ids) (syntax->list #'(be ...)))])
; XXX Optimize special case of one nv
(syntax/loc stx
(let-values ([(vv ...)
(#%plain-app values nvv-box ...)] ...)
; This is okay, because we've already expanded the syntax.
(let-syntaxes
([(sv ...) se] ...)
(begin (#%plain-app call-with-values
(#%plain-lambda () ve)
(#%plain-lambda (nvv ...)
(#%plain-app set-box! vv nvv) ...))
...
be ...))))))]
((elim-letrec ids)
(syntax/loc stx
(letrec-values ([(vv ...) ve] ...) be ...)))]
[(#%expression d)
(quasisyntax/loc stx (#%expression #,((elim-letrec ids) #'d)))]
[_

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

@ -72,15 +72,10 @@
[else
#;(printf "Not including id ~S with binding ~S in freevars~n" (syntax->datum #'id) i-bdg)
empty]))]
; XXX Shouldn't be here
[(letrec-syntaxes+values ([(sv ...) se] ...)
([(vv ...) ve] ...)
be ...)
(set-diff (union* (free-vars* (syntax->list #'(se ...)))
(free-vars* (syntax->list #'(ve ...)))
(free-vars* (syntax->list #'(be ...))))
(append (apply append (map syntax->list (syntax->list #'((sv ...) ...))))
(apply append (map syntax->list (syntax->list #'((vv ...) ...))))))]
(free-vars #'(letrec-values ([(vv ...) ve] ...) be ...))]
[(#%expression d)
(free-vars #'d)]
[_

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

@ -3,7 +3,7 @@
syntax/kerncase
mzlib/pretty
mzlib/list)
(provide (except-out (all-defined-out) template))
(provide (all-defined-out))
(define transformer? (make-parameter #f))
@ -55,19 +55,9 @@
(list (quasisyntax/loc stx
(define-values (v ...) #,nve)))))]
[(define-syntaxes (v ...) ve)
(parameterize ([transformer? #t])
(let-values ([(nve defs) (inner #'ve)])
(append
defs
(list (quasisyntax/loc stx
(define-syntaxes (v ...) #,nve))))))]
(list stx)]
[(define-values-for-syntax (v ...) ve)
(parameterize ([transformer? #t])
(let-values ([(nve defs) (inner #'ve)])
(append
defs
(list (quasisyntax/loc stx
(define-values-for-syntax (v ...) #,nve))))))]
(list stx)]
[(#%require spec ...)
(list stx)]
[expr
@ -107,68 +97,3 @@
(lambda (an-id)
(bound-identifier=? id an-id))
ids))
;; Kernel Case Template
(define (template stx)
(recertify
stx
(kernel-syntax-case
stx (transformer?)
[(begin be ...)
(with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
(syntax/loc stx
(begin be ...)))]
[(begin0 be ...)
(with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
(syntax/loc stx
(begin0 be ...)))]
[(set! v ve)
(with-syntax ([ve (template #'ve)])
(syntax/loc stx
(set! v ve)))]
[(let-values ([(v ...) ve] ...) be ...)
(with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))]
[(be ...) (map template (syntax->list #'(be ...)))])
(syntax/loc stx
(let-values ([(v ...) ve] ...) be ...)))]
[(letrec-values ([(v ...) ve] ...) be ...)
(with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))]
[(be ...) (map template (syntax->list #'(be ...)))])
(syntax/loc stx
(letrec-values ([(v ...) ve] ...) be ...)))]
[(#%plain-lambda formals be ...)
(with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
(syntax/loc stx
(#%plain-lambda formals be ...)))]
[(case-lambda [formals be ...] ...)
(with-syntax ([((be ...) ...) (map template (syntax->list #'((be ...) ...)))])
(syntax/loc stx
(case-lambda [formals be ...] ...)))]
[(if te ce ae)
(with-syntax ([te (template #'te)]
[ce (template #'ce)]
[ae (template #'ae)])
(syntax/loc stx
(if te ce ae)))]
[(quote datum)
stx]
[(quote-syntax datum)
stx]
[(with-continuation-mark ke me be)
(with-syntax ([ke (template #'ke)]
[me (template #'me)]
[be (template #'be)])
(syntax/loc stx
(with-continuation-mark ke me be)))]
[(#%plain-app e ...)
(with-syntax ([(e ...) (map template (syntax->list #'(e ...)))])
(syntax/loc stx
(#%plain-app e ...)))]
[(#%top . v)
stx]
[(#%variable-reference . v)
stx]
[id (identifier? #'id)
stx]
[_
(raise-syntax-error 'kerncase "Dropped through:" stx)])))

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

@ -272,7 +272,34 @@
(check = 4 (test-m06.1 `(dispatch ,the-dispatch (list ,second-key 3))))
(check-true (zero? (test-m06.1 `(dispatch ,the-dispatch (list ,second-key -1)))))
(check = -7 (test-m06.1 `(dispatch ,the-dispatch (list ,third-key 0))))
(check-true (zero? (test-m06.1 `(dispatch ,the-dispatch (list ,third-key 7)))))))))
(check-true (zero? (test-m06.1 `(dispatch ,the-dispatch (list ,third-key 7))))))))
(test-case
"curried with send/suspend and serializaztion (keyword args)"
(let-values ([(test-m06.2)
(make-module-eval
(module m06.2 (lib "lang.ss" "web-server")
(provide start)
(define (gn #:page which)
(cadr
(send/suspend
(lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)])
k)))))
(define (start ignore)
(let ([result (+ (gn #:page "first") (gn #:page "second"))])
(let ([ignore (printf "The answer is: ~s~n" result)])
result)))))])
(let* ([first-key (test-m06.2 '(dispatch-start start 'foo))]
[second-key (test-m06.2 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) 1)))]
[third-key (test-m06.2 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) -7)))])
(check = 3 (test-m06.2 `(abort/cc (lambda () (dispatch ,the-dispatch (list ,second-key 2))))))
(check = 4 (test-m06.2 `(dispatch ,the-dispatch (list ,second-key 3))))
(check-true (zero? (test-m06.2 `(dispatch ,the-dispatch (list ,second-key -1)))))
(check = -7 (test-m06.2 `(dispatch ,the-dispatch (list ,third-key 0))))
(check-true (zero? (test-m06.2 `(dispatch ,the-dispatch (list ,third-key 7)))))))))
(test-suite
"Test the certification process"

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

@ -45,7 +45,7 @@
;; w-alpha=/env: env target-expr target-expr -> boolean
;; are two target vars or vals alpha-equivalent?
(define (w-alpha=/env env1 env2 expr1 expr2)
(syntax-case expr1 (#%top #%plain-lambda quote)
(syntax-case expr1 (#%top #%plain-lambda quote #%expression)
[(#%top . var1)
(syntax-case expr2 (#%top)
[(#%top . var2)
@ -69,6 +69,11 @@
(extend env2 (syntax->symbols (formals-list #'formals2)) syms)
#'body1 #'body2)))]
[_else #f])]
[(#%expression e1)
(syntax-case expr2 (#%expression)
[(#%expression e2)
(w-alpha=/env env1 env2 #'e1 #'e2)]
[_else #f])]
[x1 (symbol? (syntax->datum #'x1))
(syntax-case expr2 ()
[x2 (symbol? (syntax->datum #'x2))