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

Dealing with syntax by punting

Browse Source 
svn: r6663
This commit is contained in:
Jay McCarthy 2007-06-14 20:25:46 +00:00
parent ae43910cd7
commit 9cec27f49b
9 changed files with 81 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -64,15 +64,9 @@
(syntax/loc stx
(define-values (v ...) ve)))]
[(define-syntaxes (v ...) ve)
(parameterize ([transformer? #t])
(with-syntax ([ve (anormal-term #'ve)])
(syntax/loc stx
(define-syntaxes (v ...) ve))))]
stx]
[(define-values-for-syntax (v ...) ve)
(parameterize ([transformer? #t])
(with-syntax ([ve (anormal-term #'ve)])
(syntax/loc stx
(define-values-for-syntax (v ...) ve))))]
stx]
[(set! v ve)
(anormal
(compose ctxt

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

@ -33,15 +33,11 @@
(values (quasisyntax/loc stx (define-values (v ...) #,nve))
defs))]
[(define-syntaxes (v ...) ve)
(parameterize ([transformer? #t])
(let-values ([(nve defs) (defun #'ve)])
(values (quasisyntax/loc stx (define-syntaxes (v ...) #,nve))
defs)))]
(values stx
empty)]
[(define-values-for-syntax (v ...) ve)
(parameterize ([transformer? #t])
(let-values ([(nve defs) (defun #'ve)])
(values (quasisyntax/loc stx (define-values-for-syntax (v ...) #,nve))
defs)))]
(values stx
empty)]
[(set! v ve)
(let-values ([(nve defs) (defun #'ve)])
(values (quasisyntax/loc stx (set! v #,nve))

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

@ -1,6 +1,7 @@
(module elim-callcc mzscheme
(require-for-template mzscheme
"../lang/abort-resume.ss")
(require-for-syntax "../lang/abort-resume.ss")
(require (lib "kerncase.ss" "syntax")
"util.ss")
(provide elim-callcc)
@ -42,15 +43,9 @@
(syntax/loc stx
(define-values (v ...) ve)))]
[(define-syntaxes (v ...) ve)
(parameterize ([transformer? #t])
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
(syntax/loc stx
(define-values (v ...) ve))))]
stx]
[(define-values-for-syntax (v ...) ve)
(parameterize ([transformer? #t])
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
(syntax/loc stx
(define-values-for-syntax (v ...) ve))))]
stx]
[(set! v ve)
(with-syntax ([ve (elim-callcc #'ve)])
(syntax/loc stx (set! v ve)))]
@ -158,7 +153,7 @@
[(#%app w rest ...)
(markit
(quasisyntax/loc stx
(with-continuation-mark safe-call? '(#f #,stx)
(with-continuation-mark safe-call? '(#f stx)
(#%app #,(mark-lambda-as-safe (elim-callcc #'w))
#,@(map
(lambda (an-expr)

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

@ -1,6 +1,7 @@
(module elim-letrec mzscheme
(require-for-template mzscheme
"../lang/abort-resume.ss")
(require-for-syntax "../lang/abort-resume.ss")
(require (lib "kerncase.ss" "syntax")
(lib "etc.ss")
(lib "list.ss")
@ -28,15 +29,9 @@
(syntax/loc stx
(define-values (v ...) ve)))]
[(define-syntaxes (v ...) ve)
(parameterize ([transformer? #t])
(with-syntax ([ve ((elim-letrec ids) #'ve)])
(syntax/loc stx
(define-syntaxes (v ...) ve))))]
stx]
[(define-values-for-syntax (v ...) ve)
(parameterize ([transformer? #t])
(with-syntax ([ve ((elim-letrec ids) #'ve)])
(syntax/loc stx
(define-values-for-syntax (v ...) ve))))]
stx]
[(set! v ve)
(with-syntax ([ve ((elim-letrec ids) #'ve)])
(if (bound-identifier-member? #'id ids)

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

@ -103,10 +103,10 @@
stx
(syntax-case stx ()
((mb forms ...)
(with-syntax ([(pmb rfs body ...)
(with-syntax ([(pmb rfs0 body ...)
(local-expand (quasisyntax/loc stx
(#%plain-module-begin
#,(syntax-local-introduce #'(require-for-syntax mzscheme))
#,(syntax-local-introduce #'(require-for-syntax mzscheme))
forms ...))
'module-begin
empty)])
@ -116,7 +116,7 @@
(datum->syntax-object stx (base-labeling)))])
(let ([new-defs (apply append (map transform (syntax->list #'(body ...))))])
(quasisyntax/loc stx
(pmb rfs
(pmb rfs0
#,@new-defs))))))))))
(define (bound-identifier-member? id ids)
@ -147,7 +147,7 @@
(parameterize ([transformer? #t])
(with-syntax ([ve (template #'ve)])
(syntax/loc stx
(define-values (v ...) ve))))]
(define-syntaxes (v ...) ve))))]
[(define-values-for-syntax (v ...) ve)
(parameterize ([transformer? #t])
(with-syntax ([ve (template #'ve)])

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

@ -497,4 +497,34 @@
(let ([k0 (ta-eval '(dispatch-start start 'foo))])
(check = 3 (ta-eval `(dispatch ,the-dispatch (list ,k0 2))))
(check = 0 (ta-eval `(dispatch ,the-dispatch (list ,k0 -1)))))))))))
(check = 0 (ta-eval `(dispatch ,the-dispatch (list ,k0 -1))))))))
(test-suite
"Weird Cases"
(test-case
"provide/contract: simple"
(check-not-exn
(lambda ()
(make-module-eval
(module data (lib "lang.ss" "web-server")
(require (lib "contract.ss"))
(define x 1)
(provide/contract
[x integer?]))))))
(test-case
"provide/contract: struct"
(check-not-exn
(lambda ()
(make-module-eval
(module data (lib "lang.ss" "web-server")
(require (lib "contract.ss"))
(define-struct posn (x y))
(provide/contract
[struct posn ([x integer?] [y integer?])])))))))
)))

2
collects/web-server/tests/lang/all-lang-tests.ss
View File

@ -1,6 +1,7 @@
(module all-lang-tests mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
"anormal-test.ss"
"defun-test.ss"
"file-box-test.ss"
"labels-test.ss"
"stuff-url-test.ss"
@ -11,6 +12,7 @@
(test-suite
"Web Language"
anormal-tests
defun-tests
file-box-tests
labels-tests
stuff-url-tests

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

@ -332,4 +332,9 @@
(* (car l) (cdr l))])))))
#t)))
(test-not-exn "define-struct" (lambda () (normalize-term (expand (syntax (define-struct posn (x y)))))))))))
(test-not-exn "define-struct" (lambda () (normalize-term (expand (syntax (define-struct posn (x y)))))))
(test-not-exn "quote-syntax: #f" (lambda () (parameterize ([transformer? #f])
(normalize-term (expand (syntax #'provide/contract-id-set-a-date-day!))))))
(test-not-exn "quote-syntax: #t" (lambda () (parameterize ([transformer? #t])
(normalize-term (expand (syntax #'provide/contract-id-set-a-date-day!))))))
))))

25
collects/web-server/tests/lang/defun-test.ss Normal file
View File

@ -0,0 +1,25 @@
(module defun-test mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(lib "defun.ss" "web-server" "lang")
(lib "util.ss" "web-server" "lang"))
(provide defun-tests)
(define-syntax vwrap
(syntax-rules ()
[(_ e)
(call-with-values
(lambda () e)
(lambda x x))]))
(define defun-tests
(test-suite
"Defunctionalization"
(test-not-exn "define-struct" (lambda () (vwrap (defun (expand (syntax (define-struct posn (x y))))))))
(test-not-exn "quote-syntax" (lambda () (vwrap (defun (expand (syntax #'provide/contract-id-set-a-date-day!))))))
#;(test-not-exn "provide/contract" (lambda () (vwrap (defun (expand (syntax (module t mzscheme
(require (lib "contract.ss"))
(define x 1)
(provide/contract
[x integer?]))))))))
)))