Adding new full kernel-syntax source transformers
svn: r6270
This commit is contained in:
Jay McCarthy
parent
d0318270a4
commit
4867462a7f
180
collects/web-server/prototype-web-server/newcont/anormal.ss
Normal file
180
collects/web-server/prototype-web-server/newcont/anormal.ss
Normal file
|
|
@ -0,0 +1,180 @@
|
|||
(module anormal mzscheme
|
||||
(require-for-template mzscheme)
|
||||
(require (lib "kerncase.ss" "syntax")
|
||||
#;(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "toplevel.ss" "syntax")
|
||||
(lib "plt-match.ss")
|
||||
(lib "stx.ss" "syntax")
|
||||
"util.ss")
|
||||
(provide make-anormal-term)
|
||||
|
||||
; A-Normal Form
|
||||
(define (id x) x)
|
||||
|
||||
;; a context is either
|
||||
;; frame
|
||||
;; (compose context frame)
|
||||
|
||||
;; a frame is either
|
||||
;; w -> target-redex
|
||||
;; (listof w) -> target-redex
|
||||
|
||||
;; compose: (w -> target-expr) (alpha -> target-redex) -> (alpha -> target-expr)
|
||||
;; compose a context with a frame
|
||||
(define (compose ctxt frame)
|
||||
(if (eq? ctxt id)
|
||||
frame
|
||||
(lambda (val)
|
||||
(let-values ([(x ref-to-x) (generate-formal 'x)])
|
||||
#`(#%app (lambda (#,x) #,(ctxt ref-to-x)) #,(frame val))))))
|
||||
|
||||
(define (make-anormal-term elim-letrec-term)
|
||||
(define (anormal-term stx)
|
||||
(anormal id stx))
|
||||
|
||||
(define (anormal ctxt stx)
|
||||
(kernel-syntax-case
|
||||
stx #f
|
||||
[(begin)
|
||||
(anormal ctxt (syntax/loc stx (#%app (#%top . void))))]
|
||||
[(begin lbe)
|
||||
(anormal ctxt (syntax/loc stx lbe))]
|
||||
[(begin fbe be ...)
|
||||
; XXX Am I a bug?
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(let-values ([(throw-away) fbe])
|
||||
(begin be ...))))]
|
||||
[(begin0)
|
||||
(anormal ctxt (syntax/loc stx (#%app (#%top . void))))]
|
||||
[(begin0 lbe)
|
||||
(anormal ctxt (syntax/loc stx lbe))]
|
||||
[(begin0 fbe be ...)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(let-values ([(save) fbe])
|
||||
(begin be ... save))))]
|
||||
[(define-values (v ...) ve)
|
||||
(with-syntax ([ve (anormal-term #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(with-syntax ([ve (anormal-term #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(with-syntax ([ve (anormal-term #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values-for-syntax (v ...) ve)))]
|
||||
[(set! v ve)
|
||||
(anormal
|
||||
(compose ctxt
|
||||
(lambda (val)
|
||||
(quasisyntax/loc stx (set! v #,val))))
|
||||
#'ve)]
|
||||
[(let-values () be)
|
||||
(anormal ctxt (syntax/loc stx be))]
|
||||
[(let-values ([(v) ve]) be)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(#%app (lambda (v) be)
|
||||
ve)))]
|
||||
[(let-values ([(v ...) ve]) be)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(#%app call-with-values
|
||||
(lambda () ve)
|
||||
(lambda (v ...) be))))]
|
||||
[(let-values ([(fv ...) fve] [(v ...) ve] ...) be)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(let-values ([(fv ...) fve])
|
||||
(let-values ([(v ...) ve] ...)
|
||||
be))))]
|
||||
[(let-values ([(v ...) ve] ...) be ...)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx
|
||||
(let-values ([(v ...) ve] ...)
|
||||
(begin be ...))))]
|
||||
[(letrec-values ([(v ...) ve] ...) be ...)
|
||||
(anormal ctxt
|
||||
(elim-letrec-term stx))]
|
||||
[(lambda formals be ...)
|
||||
(with-syntax ([nbe (anormal-term (syntax/loc stx (begin be ...)))])
|
||||
(ctxt (syntax/loc stx (lambda formals nbe))))]
|
||||
[(case-lambda [formals be] ...)
|
||||
(with-syntax ([(be ...) (map anormal-term (syntax->list #'(be ...)))])
|
||||
(ctxt (syntax/loc stx (case-lambda [formals be] ...))))]
|
||||
[(case-lambda [formals be ...] ...)
|
||||
(anormal ctxt
|
||||
(syntax/loc stx (case-lambda [formals (begin be ...)] ...)))]
|
||||
[(if te ce ae)
|
||||
(anormal
|
||||
(compose ctxt
|
||||
(lambda (val)
|
||||
(quasisyntax/loc stx
|
||||
(if #,val
|
||||
#,(anormal-term #'ce)
|
||||
#,(anormal-term #'ae)))))
|
||||
#'te)]
|
||||
[(if te ce)
|
||||
(anormal ctxt (syntax/loc stx (if te ce (#%app void))))]
|
||||
[(quote datum)
|
||||
(ctxt stx)]
|
||||
[(quote-syntax datum)
|
||||
(ctxt stx)]
|
||||
[(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)
|
||||
(raise-syntax-error 'anormal "XXX What do I do with letrec-syntaxes+values?" stx)]
|
||||
[(with-continuation-mark ke me be)
|
||||
(anormal
|
||||
(compose ctxt
|
||||
(lambda (kev)
|
||||
(anormal
|
||||
(lambda (mev)
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark #,kev #,mev
|
||||
#,(anormal-term #'be))))
|
||||
#'me)))
|
||||
#'ke)]
|
||||
[(#%expression . d)
|
||||
(ctxt stx)]
|
||||
[(#%app fe e ...)
|
||||
(anormal
|
||||
(lambda (val0)
|
||||
(anormal*
|
||||
(compose ctxt
|
||||
(lambda (rest-vals)
|
||||
(quasisyntax/loc stx
|
||||
(#%app #,val0 #,@rest-vals))))
|
||||
(syntax->list #'(e ...))))
|
||||
#'fe)]
|
||||
[(#%top . v)
|
||||
(ctxt stx)]
|
||||
[(#%datum . d)
|
||||
(ctxt stx)]
|
||||
[(#%variable-reference . v)
|
||||
(ctxt stx)]
|
||||
[id (identifier? #'id)
|
||||
(ctxt #'id)]
|
||||
[_
|
||||
(raise-syntax-error 'anormal "Dropped through:" stx)]))
|
||||
|
||||
;; anormal*: ((listof w) -> target-expr) (listof source-expr) -> target-expr
|
||||
;; normalize an expression given as a context and list of sub-expressions
|
||||
(define (anormal* multi-ctxt exprs)
|
||||
(match exprs
|
||||
[(list)
|
||||
(multi-ctxt '())]
|
||||
[(list-rest fe re)
|
||||
(anormal
|
||||
(lambda (val)
|
||||
(anormal*
|
||||
(lambda (rest-vals)
|
||||
(multi-ctxt (list* val rest-vals)))
|
||||
re))
|
||||
fe)]))
|
||||
|
||||
anormal-term))
|
||||
155
collects/web-server/prototype-web-server/newcont/defun.ss
Normal file
155
collects/web-server/prototype-web-server/newcont/defun.ss
Normal file
|
|
@ -0,0 +1,155 @@
|
|||
(module defun mzscheme
|
||||
(require-for-template mzscheme)
|
||||
(require (lib "kerncase.ss" "syntax")
|
||||
#;(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "toplevel.ss" "syntax")
|
||||
(lib "plt-match.ss")
|
||||
(lib "stx.ss" "syntax")
|
||||
"util.ss"
|
||||
"freevars.ss"
|
||||
(lib "closure.ss" "prototype-web-server"))
|
||||
(provide defun)
|
||||
|
||||
; make-new-clouse-label : (syntax -> syntax) syntax -> syntax
|
||||
(define (make-new-closure-label labeling stx)
|
||||
(labeling stx))
|
||||
|
||||
; defun : syntax[1] -> (values syntax?[2] (listof syntax?)[3])
|
||||
; defunctionalizes the first syntax, returning the second and the lifted lambdas [3]
|
||||
(define (defun stx)
|
||||
(kernel-syntax-case
|
||||
stx #f
|
||||
[(begin be ...)
|
||||
(let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))])
|
||||
(values (quasisyntax/loc stx (begin #,@nbes))
|
||||
defs))]
|
||||
[(begin0 be ...)
|
||||
(let-values ([(nbes defs) (defun* (syntax->list #'(be ...)))])
|
||||
(values (quasisyntax/loc stx (begin0 #,@nbes))
|
||||
defs))]
|
||||
[(define-values (v ...) ve)
|
||||
(let-values ([(nve defs) (defun #'ve)])
|
||||
(values (quasisyntax/loc stx (define-values (v ...) #,nve))
|
||||
defs))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(let-values ([(nve defs) (defun #'ve)])
|
||||
(values (quasisyntax/loc stx (define-syntaxes (v ...) #,nve))
|
||||
defs))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(let-values ([(nve defs) (defun #'ve)])
|
||||
(values (quasisyntax/loc stx (define-values-for-syntax (v ...) #,nve))
|
||||
defs))]
|
||||
[(set! v ve)
|
||||
(let-values ([(nve defs) (defun #'ve)])
|
||||
(values (quasisyntax/loc stx (set! v #,nve))
|
||||
defs))]
|
||||
[(let-values ([(v ...) ve] ...) be ...)
|
||||
(let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))]
|
||||
[(nbes be-defs) (defun* (syntax->list #'(be ...)))])
|
||||
(with-syntax ([(nve ...) nves]
|
||||
[(nbe ...) nbes])
|
||||
(values (syntax/loc stx (let-values ([(v ...) nve] ...) nbe ...))
|
||||
(append ve-defs be-defs))))]
|
||||
[(letrec-values ([(v ...) ve] ...) be ...)
|
||||
(let-values ([(nves ve-defs) (defun* (syntax->list #'(ve ...)))]
|
||||
[(nbes be-defs) (defun* (syntax->list #'(be ...)))])
|
||||
(with-syntax ([(nve ...) nves]
|
||||
[(nbe ...) nbes])
|
||||
(values (syntax/loc stx (letrec-values ([(v ...) nve] ...) nbe ...))
|
||||
(append ve-defs be-defs))))]
|
||||
[(lambda formals be ...)
|
||||
(let-values ([(nbes be-defs) (defun* (syntax->list #'(be ...)))])
|
||||
(with-syntax ([(nbe ...) nbes])
|
||||
(let ([fvars (free-vars stx)])
|
||||
(let-values ([(make-CLOSURE new-defs)
|
||||
(make-closure-definition-syntax
|
||||
(make-new-closure-label (current-code-labeling) stx)
|
||||
fvars
|
||||
(syntax/loc stx (lambda formals nbe ...)))])
|
||||
(values (if (empty? fvars)
|
||||
(quasisyntax/loc stx (#,make-CLOSURE))
|
||||
(quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars)))))
|
||||
(append be-defs new-defs))))))]
|
||||
[(case-lambda [formals be ...] ...)
|
||||
(let-values ([(nbes be-defs) (defun** (syntax->list #'((be ...) ...)))])
|
||||
(with-syntax ([((nbe ...) ...) nbes])
|
||||
(let ([fvars (free-vars stx)])
|
||||
(let-values ([(make-CLOSURE new-defs)
|
||||
(make-closure-definition-syntax
|
||||
(make-new-closure-label (current-code-labeling) stx)
|
||||
fvars
|
||||
(syntax/loc stx (case-lambda [formals nbe ...] ...)))])
|
||||
(values (if (empty? fvars)
|
||||
(quasisyntax/loc stx (#,make-CLOSURE))
|
||||
(quasisyntax/loc stx (#,make-CLOSURE (lambda () (values #,@fvars)))))
|
||||
(append be-defs new-defs))))))]
|
||||
[(if te ce ae)
|
||||
(let-values ([(es defs) (defun* (syntax->list #'(te ce ae)))])
|
||||
(values (quasisyntax/loc stx (if #,@es))
|
||||
defs))]
|
||||
[(if te ce)
|
||||
(defun (quasisyntax/loc stx (if te ce (#%app void))))]
|
||||
[(quote datum)
|
||||
(values stx
|
||||
empty)]
|
||||
[(quote-syntax datum)
|
||||
(values stx
|
||||
empty)]
|
||||
[(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)
|
||||
(let-values ([(nses se-defs) (defun* (syntax->list #'(se ...)))]
|
||||
[(nves ve-defs) (defun* (syntax->list #'(ve ...)))]
|
||||
[(nbes be-defs) (defun* (syntax->list #'(be ...)))])
|
||||
(with-syntax ([(nse ...) nses]
|
||||
[(nve ...) nves]
|
||||
[(nbe ...) nbes])
|
||||
(values (syntax/loc stx
|
||||
(letrec-syntaxes+values ([(sv ...) nse] ...)
|
||||
([(vv ...) nve] ...)
|
||||
nbe ...))
|
||||
(append se-defs ve-defs be-defs))))]
|
||||
[(with-continuation-mark ke me be)
|
||||
(let-values ([(es defs) (defun* (list #'ke #'me #'be))])
|
||||
(values (quasisyntax/loc stx (with-continuation-mark #,@es))
|
||||
defs))]
|
||||
[(#%expression . d)
|
||||
(values stx
|
||||
empty)]
|
||||
[(#%app e ...)
|
||||
(let-values ([(es defs) (defun* (syntax->list #'(e ...)))])
|
||||
(values (quasisyntax/loc stx (#%app #,@es))
|
||||
defs))]
|
||||
[(#%top . v)
|
||||
(values stx
|
||||
empty)]
|
||||
[(#%datum . d)
|
||||
(values stx
|
||||
empty)]
|
||||
[(#%variable-reference . v)
|
||||
(values stx
|
||||
empty)]
|
||||
[id (identifier? #'id)
|
||||
(values stx
|
||||
empty)]
|
||||
[_
|
||||
(raise-syntax-error 'defun "Dropped through:" stx)]))
|
||||
|
||||
; lift defun to list of syntaxes
|
||||
(define (lift-defun defun)
|
||||
(lambda (stxs)
|
||||
(match
|
||||
(foldl (lambda (stx acc)
|
||||
(let-values ([(nstx stx-defs) (defun stx)])
|
||||
(match acc
|
||||
[(list-rest nstxs defs)
|
||||
(cons (list* nstx nstxs)
|
||||
(append stx-defs defs))])))
|
||||
(cons empty empty)
|
||||
stxs)
|
||||
[(list-rest nstxs defs)
|
||||
(values (reverse nstxs)
|
||||
defs)])))
|
||||
(define defun* (lift-defun defun))
|
||||
(define defun** (lift-defun (lambda (stx) (defun* (syntax->list stx))))))
|
||||
175
collects/web-server/prototype-web-server/newcont/elim-callcc.ss
Normal file
175
collects/web-server/prototype-web-server/newcont/elim-callcc.ss
Normal file
|
|
@ -0,0 +1,175 @@
|
|||
(module elim-callcc mzscheme
|
||||
(require-for-template mzscheme)
|
||||
(require-for-template (lib "abort-resume.ss" "prototype-web-server"))
|
||||
(require (lib "kerncase.ss" "syntax")
|
||||
#;(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "toplevel.ss" "syntax")
|
||||
(lib "plt-match.ss")
|
||||
(lib "stx.ss" "syntax")
|
||||
"util.ss")
|
||||
(provide elim-callcc)
|
||||
|
||||
(define (id x) x)
|
||||
|
||||
;; mark-lambda-as-safe: w -> w
|
||||
;; If w is a lambda-expression then add #t to the safety mark, otherwise no mark
|
||||
(define (mark-lambda-as-safe w)
|
||||
(syntax-case w (lambda case-lambda)
|
||||
[(lambda formals be ...)
|
||||
(syntax/loc w
|
||||
(lambda formals
|
||||
(with-continuation-mark safe-call? '(#t (lambda formals))
|
||||
be ...)))]
|
||||
[(case-lambda [formals be ...] ...)
|
||||
(syntax/loc w
|
||||
(case-lambda [formals
|
||||
(with-continuation-mark safe-call? '(#t (case-lambda formals ...))
|
||||
be ...)] ...))]
|
||||
[_else w]))
|
||||
|
||||
(define (elim-callcc stx)
|
||||
(elim-callcc/mark id stx))
|
||||
|
||||
(define (elim-callcc/mark markit stx)
|
||||
(kernel-syntax-case*
|
||||
stx #f (call/cc call-with-values)
|
||||
[(begin be ...)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(begin0 be ...)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(define-values (v ...) ve)
|
||||
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(with-syntax ([ve (mark-lambda-as-safe (elim-callcc #'ve))])
|
||||
(syntax/loc stx
|
||||
(define-values-for-syntax (v ...) ve)))]
|
||||
[(set! v ve)
|
||||
(with-syntax ([ve (elim-callcc #'ve)])
|
||||
(syntax/loc stx (set! v ve)))]
|
||||
[(let-values ([(v ...) ve] ...) be ...)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(letrec-values ([(v ...) ve] ...) be ...)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(lambda formals be)
|
||||
(with-syntax ([be (elim-callcc #'be)])
|
||||
(syntax/loc stx
|
||||
(lambda formals be)))]
|
||||
[(case-lambda [formals be] ...)
|
||||
(with-syntax ([(be ...) (map elim-callcc (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(case-lambda [formals be] ...)))]
|
||||
[(if te ce ae)
|
||||
(with-syntax ([te (elim-callcc #'te)]
|
||||
[ce (elim-callcc #'ce)]
|
||||
[ae (elim-callcc #'ae)])
|
||||
(markit (syntax/loc stx (if te ce ae))))]
|
||||
[(if te ce)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(quote datum)
|
||||
stx]
|
||||
[(quote-syntax datum)
|
||||
stx]
|
||||
[(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)
|
||||
(raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)]
|
||||
[(with-continuation-mark ke me be)
|
||||
(let* ([ke-prime (elim-callcc #'ke)]
|
||||
[me-prime (elim-callcc #'me)]
|
||||
[be-prime (elim-callcc #'be)])
|
||||
(markit
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark #,ke-prime #,me-prime
|
||||
(with-continuation-mark the-save-cm-key (#%app cons #,ke-prime #,me-prime)
|
||||
#,be-prime)))))]
|
||||
[(#%expression . d)
|
||||
stx]
|
||||
[(#%app call/cc w)
|
||||
(let-values ([(cm ref-to-cm) (generate-formal 'current-marks)]
|
||||
[(x ref-to-x) (generate-formal 'x)])
|
||||
(markit
|
||||
(quasisyntax/loc stx
|
||||
(#%app #,(elim-callcc #'w)
|
||||
(#%app (lambda (#,cm)
|
||||
(lambda #,x
|
||||
(#%app abort
|
||||
(lambda () (#%app resume #,ref-to-cm #,ref-to-x)))))
|
||||
(#%app activation-record-list))))))]
|
||||
[(#%app call-with-values (lambda () prod) cons)
|
||||
(let ([cons-prime (mark-lambda-as-safe (elim-callcc #'cons))])
|
||||
(markit
|
||||
(quasisyntax/loc stx
|
||||
(#%app call-with-values
|
||||
#,(mark-lambda-as-safe
|
||||
(quasisyntax/loc stx
|
||||
(lambda ()
|
||||
#,(elim-callcc/mark
|
||||
(lambda (x)
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark the-cont-key #,cons-prime #,x)))
|
||||
#'prod))))
|
||||
#,cons-prime))))]
|
||||
[(#%app w (#%app . stuff))
|
||||
(with-syntax ([e #'(#%app . stuff)])
|
||||
(syntax-case #'w (lambda case-lambda)
|
||||
[(lambda formals body)
|
||||
(let ([w-prime (datum->syntax-object #f (gensym 'l))])
|
||||
(quasisyntax/loc stx
|
||||
(let-values ([(#,w-prime) #,(elim-callcc #'w)])
|
||||
#,(markit
|
||||
(quasisyntax/loc stx
|
||||
(#%app #,w-prime
|
||||
#,(elim-callcc/mark
|
||||
(lambda (x)
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark the-cont-key #,w-prime #,x)))
|
||||
#'e)))))))]
|
||||
[(case-lambda [formals body] ...)
|
||||
(let ([w-prime (datum->syntax-object #f (gensym 'cl))])
|
||||
(quasisyntax/loc stx
|
||||
(let-values ([(#,w-prime) #,(elim-callcc #'w)])
|
||||
#,(markit
|
||||
(quasisyntax/loc stx
|
||||
(#%app #,w-prime
|
||||
#,(elim-callcc/mark
|
||||
(lambda (x)
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark the-cont-key #,w-prime #,x)))
|
||||
#'e)))))))]
|
||||
[_else
|
||||
(let ([w-prime (elim-callcc #'w)])
|
||||
(markit
|
||||
(quasisyntax/loc stx
|
||||
(#%app #,w-prime
|
||||
#,(elim-callcc/mark
|
||||
(lambda (x)
|
||||
#`(with-continuation-mark the-cont-key #,w-prime #,x))
|
||||
#'e)))))]))]
|
||||
[(#%app w rest ...)
|
||||
(markit
|
||||
(quasisyntax/loc stx
|
||||
(with-continuation-mark safe-call? '(#f #,stx)
|
||||
(#%app #,(mark-lambda-as-safe (elim-callcc #'w))
|
||||
#,@(map
|
||||
(lambda (an-expr)
|
||||
(mark-lambda-as-safe
|
||||
(elim-callcc
|
||||
an-expr)))
|
||||
(syntax->list #'(rest ...)))))))]
|
||||
[(#%top . v)
|
||||
stx]
|
||||
[(#%datum . d)
|
||||
stx]
|
||||
[(#%variable-reference . v)
|
||||
stx]
|
||||
[id (identifier? #'id)
|
||||
stx]
|
||||
[_
|
||||
(raise-syntax-error 'elim-callcc "Dropped through:" stx)])))
|
||||
140
collects/web-server/prototype-web-server/newcont/elim-letrec.ss
Normal file
140
collects/web-server/prototype-web-server/newcont/elim-letrec.ss
Normal file
|
|
@ -0,0 +1,140 @@
|
|||
(module elim-letrec mzscheme
|
||||
(require-for-template
|
||||
(lib "abort-resume.ss" "prototype-web-server")
|
||||
mzscheme)
|
||||
(require (lib "kerncase.ss" "syntax")
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "toplevel.ss" "syntax")
|
||||
(lib "stx.ss" "syntax")
|
||||
"util.ss")
|
||||
(provide (all-defined))
|
||||
|
||||
; 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)
|
||||
(kernel-syntax-case
|
||||
stx #f
|
||||
[(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 ...)))]
|
||||
[(define-values (v ...) ve)
|
||||
(with-syntax ([ve ((elim-letrec ids) #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(with-syntax ([ve ((elim-letrec ids) #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-syntaxes (v ...) ve)))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(with-syntax ([ve ((elim-letrec ids) #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values-for-syntax (v ...) ve)))]
|
||||
[(set! v ve)
|
||||
(with-syntax ([ve ((elim-letrec ids) #'ve)])
|
||||
(if (bound-identifier-member? #'id ids)
|
||||
(syntax/loc stx (#%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 ...) ...))))])
|
||||
(with-syntax ([((nv ...) ...) (map (compose generate-temporaries syntax->list) (syntax->list #'((v ...) ...)))]
|
||||
[((nv-box ...) ...) (map (lambda (nvs)
|
||||
(map (lambda (x) (syntax/loc x (#%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 ...)))])
|
||||
; XXX Optimize special case of one nv
|
||||
(syntax/loc stx
|
||||
(let-values ([(v ...)
|
||||
(#%app values nv-box ...)] ...)
|
||||
(begin (#%app call-with-values
|
||||
(lambda () ve)
|
||||
(lambda (nv ...)
|
||||
(#%app set-box! v nv) ...))
|
||||
...
|
||||
be ...)))))]
|
||||
[(lambda formals be ...)
|
||||
(with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(lambda formals be ...)))]
|
||||
[(case-lambda [formals be ...] ...)
|
||||
(with-syntax ([((be ...) ...) (map (elim-letrec ids) (syntax->list #'((be ...) ...)))])
|
||||
(syntax/loc stx
|
||||
(case-lambda [formals 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)))]
|
||||
[(if te ce)
|
||||
((elim-letrec ids)
|
||||
(syntax/loc stx
|
||||
(if te ce (#%app (#%top . void)))))]
|
||||
[(quote datum)
|
||||
stx]
|
||||
[(quote-syntax datum)
|
||||
stx]
|
||||
[(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 (#%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 ...)
|
||||
(#%app values nvv-box ...)] ...)
|
||||
; This is okay, because we've already expanded the syntax.
|
||||
(let-syntaxes
|
||||
([(sv ...) se] ...)
|
||||
(begin (#%app call-with-values
|
||||
(lambda () ve)
|
||||
(lambda (nvv ...)
|
||||
(#%app set-box! vv nvv) ...))
|
||||
...
|
||||
be ...))))))]
|
||||
[(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)))]
|
||||
[(#%expression . d)
|
||||
stx]
|
||||
[(#%app e ...)
|
||||
(with-syntax ([(e ...) (map (elim-letrec ids) (syntax->list #'(e ...)))])
|
||||
(syntax/loc stx
|
||||
(#%app e ...)))]
|
||||
[(#%top . v)
|
||||
stx]
|
||||
[(#%datum . d)
|
||||
stx]
|
||||
[(#%variable-reference . v)
|
||||
stx]
|
||||
[id (identifier? #'id)
|
||||
(if (bound-identifier-member? #'id ids)
|
||||
(syntax/loc stx (#%app unbox id))
|
||||
#'id)]
|
||||
[_
|
||||
(raise-syntax-error 'elim-letrec "Dropped through:" stx)]))
|
||||
|
||||
(define elim-letrec-term (elim-letrec empty)))
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
(module add-param (lib "newcont.ss" "newcont")
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "servlet-helpers.ss" "web-server" "private"))
|
||||
(provide start)
|
||||
|
||||
(define msg (make-parameter "unknown"))
|
||||
|
||||
(define (gn)
|
||||
(printf "gn ~a~n" (msg))
|
||||
(let* ([req
|
||||
(send/suspend/url
|
||||
(lambda (k-url)
|
||||
(printf "ssu ~S~n" (msg))
|
||||
`(hmtl (head (title ,(format "Get ~a number" (msg))))
|
||||
(body
|
||||
(form ([action ,(url->string k-url)]
|
||||
[method "post"]
|
||||
[enctype "application/x-www-form-urlencoded"])
|
||||
,(format "Enter the ~a number to add: " (msg))
|
||||
(input ([type "text"] [name "number"] [value ""]))
|
||||
(input ([type "submit"])))))))]
|
||||
[num (string->number
|
||||
(extract-binding/single
|
||||
'number
|
||||
(request-bindings req)))])
|
||||
(printf "gn ~a ~a~n" (msg) num)
|
||||
num))
|
||||
|
||||
(define (start initial-request)
|
||||
(printf "after s-s~n")
|
||||
`(html (head (title "Final Page"))
|
||||
(body
|
||||
(h1 "Final Page")
|
||||
(p ,(format "The answer is ~a"
|
||||
(+ (parameterize ([msg "first"])
|
||||
(gn))
|
||||
(parameterize ([msg "second"])
|
||||
(gn)))))))))
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
(module add-simple (lib "newcont.ss" "newcont")
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "servlet-helpers.ss" "web-server" "private")
|
||||
(lib "web-param.ss" "newcont"))
|
||||
(provide start)
|
||||
|
||||
(define msg (make-web-parameter "unknown"))
|
||||
|
||||
(define (gn)
|
||||
(printf "gn ~a~n" (msg))
|
||||
(let* ([req
|
||||
(send/suspend/url
|
||||
(lambda (k-url)
|
||||
(printf "ssu ~S~n" (msg))
|
||||
`(hmtl (head (title ,(format "Get ~a number" (msg))))
|
||||
(body
|
||||
(form ([action ,(url->string k-url)]
|
||||
[method "post"]
|
||||
[enctype "application/x-www-form-urlencoded"])
|
||||
,(format "Enter the ~a number to add: " (msg))
|
||||
(input ([type "text"] [name "number"] [value ""]))
|
||||
(input ([type "submit"])))))))]
|
||||
[num (string->number
|
||||
(extract-binding/single
|
||||
'number
|
||||
(request-bindings req)))])
|
||||
(printf "gn ~a ~a~n" (msg) num)
|
||||
num))
|
||||
|
||||
(define (start initial-request)
|
||||
(printf "after s-s~n")
|
||||
`(html (head (title "Final Page"))
|
||||
(body
|
||||
(h1 "Final Page")
|
||||
(p ,(format "The answer is ~a"
|
||||
(+ (web-parameterize ([msg "first"])
|
||||
(gn))
|
||||
(web-parameterize ([msg "second"])
|
||||
(gn)))))))))
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
(module add (lib "newcont.ss" "newcont")
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "servlet-helpers.ss" "web-server" "private"))
|
||||
(provide start)
|
||||
|
||||
;; get-number-from-user: string -> number
|
||||
;; ask the user for a number
|
||||
(define (get-number msg)
|
||||
(printf "gn ~a~n" msg)
|
||||
(let* ([req
|
||||
(send/suspend/url
|
||||
(lambda (k-url)
|
||||
(printf "ssu~n")
|
||||
`(hmtl (head (title ,(format "Get ~a number" msg)))
|
||||
(body
|
||||
(form ([action ,(url->string k-url)]
|
||||
[method "post"]
|
||||
[enctype "application/x-www-form-urlencoded"])
|
||||
,(format "Enter the ~a number to add: " msg)
|
||||
(input ([type "text"] [name "number"] [value ""]))
|
||||
(input ([type "submit"])))))))]
|
||||
[num (string->number
|
||||
(extract-binding/single
|
||||
'number
|
||||
(request-bindings req)))])
|
||||
(printf "gn ~a ~a~n" msg num)
|
||||
num))
|
||||
|
||||
(define (start initial-request)
|
||||
(printf "after s-s~n")
|
||||
`(html (head (title "Final Page"))
|
||||
(body
|
||||
(h1 "Final Page")
|
||||
(p ,(format "The answer is ~a"
|
||||
(+ (get-number "first") (get-number "second"))))))))
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
(module temp (lib "newcont.ss" "newcont")
|
||||
(provide start)
|
||||
|
||||
(define msg (make-parameter "unknown"))
|
||||
|
||||
(define (gn should-be i)
|
||||
(let/cc k
|
||||
(printf "~S == ~S~n" should-be (msg))
|
||||
i))
|
||||
|
||||
(define (start)
|
||||
'(fun . #t)
|
||||
(printf "12 + 1 = 13 = ~S~n"
|
||||
(+
|
||||
(parameterize ([msg "first"])
|
||||
(gn "first" 12))
|
||||
(parameterize ([msg "second"])
|
||||
(gn "second" 1))))))
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
(module wc-comp (lib "newcont.ss" "newcont")
|
||||
(require (lib "web-cells.ss" "newcont")
|
||||
(lib "web-cell-component.ss" "newcont")
|
||||
(lib "url.ss" "net"))
|
||||
(provide start)
|
||||
|
||||
(define (start initial-request)
|
||||
; A top-level frame must exist
|
||||
(define counter1 (make-counter))
|
||||
(define counter2 (make-counter))
|
||||
; counter1 and counter2 must have been added to the top-level frame
|
||||
(define include1 (include-counter counter1))
|
||||
(define include2 (include-counter counter2))
|
||||
; counter1 and counter2 may have been modified
|
||||
(send/suspend/dispatch
|
||||
(lambda (embed/url)
|
||||
; The frame (ref) must have been captured, any changes to web-cells after this will be lost
|
||||
`(html
|
||||
(body (h2 "Web Cell Test")
|
||||
(div (h3 "First")
|
||||
,(include1 embed/url))
|
||||
(div (h3 "Second")
|
||||
,(include2 embed/url)))))))
|
||||
|
||||
(define (make-counter) (make-web-cell 0))
|
||||
(define-component (include-counter counter (a-counter) embed/url)
|
||||
`(div (h3 ,(number->string (web-cell-ref a-counter)))
|
||||
(a ([href ,(url->string
|
||||
(embed/url
|
||||
(lambda _
|
||||
; A new frame has been created
|
||||
(define last (web-cell-ref a-counter))
|
||||
; It is a child of the parent frame, so we can inspect the value
|
||||
(web-cell-mask a-counter (add1 last))
|
||||
; The new frame has been modified
|
||||
(counter))))])
|
||||
"+"))))
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
(module wc-fake (lib "newcont.ss" "newcont")
|
||||
(require (lib "url.ss" "net"))
|
||||
(provide start)
|
||||
|
||||
(define (start initial-request)
|
||||
(define counter1 0)
|
||||
(define counter2 0)
|
||||
(send/suspend/dispatch
|
||||
(lambda (embed/url)
|
||||
(let*-values ([(inc1 next-counter1 next-counter2) (include-counter counter1 counter2 embed/url)]
|
||||
[(inc2 next-counter2 next-counter1) (include-counter next-counter2 next-counter1 embed/url)])
|
||||
`(html
|
||||
(body (h2 "Web Cell Test")
|
||||
(div (h3 "First") ,(inc1 next-counter1 next-counter2))
|
||||
(div (h3 "Second") ,(inc2 next-counter2 next-counter1))))))))
|
||||
|
||||
(define (include-counter my-counter other-counter embed/url)
|
||||
(let/cc k
|
||||
(letrec ([include
|
||||
(lambda (next-my-counter next-other-counter)
|
||||
`(div (h3 ,(number->string next-my-counter))
|
||||
(a ([href
|
||||
,(url->string
|
||||
(embed/url
|
||||
(lambda _
|
||||
(k include
|
||||
(add1 next-my-counter)
|
||||
next-other-counter))))])
|
||||
"Increment")))])
|
||||
(values include
|
||||
my-counter
|
||||
other-counter)))))
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
(module wc (lib "newcont.ss" "newcont")
|
||||
(require (lib "web-cells.ss" "newcont")
|
||||
(lib "url.ss" "net"))
|
||||
(provide start)
|
||||
|
||||
(define (start initial-request)
|
||||
; A top-level frame must exist
|
||||
(define counter1 (make-counter))
|
||||
(define counter2 (make-counter))
|
||||
; counter1 and counter2 must have been added to the top-level frame
|
||||
(define include1 (include-counter counter1))
|
||||
(define include2 (include-counter counter2))
|
||||
; counter1 and counter2 may have been modified
|
||||
(send/suspend/dispatch
|
||||
(lambda (embed/url)
|
||||
; The frame (ref) must have been captured, any changes to web-cells after this will be lost
|
||||
`(html
|
||||
(body (h2 "Web Cell Test")
|
||||
(div (h3 "First")
|
||||
,(include1 embed/url))
|
||||
(div (h3 "Second")
|
||||
,(include2 embed/url)))))))
|
||||
|
||||
(define (make-counter)
|
||||
(make-web-cell 0))
|
||||
|
||||
(define (include-counter a-counter)
|
||||
(let/cc k
|
||||
(define (generate)
|
||||
(k
|
||||
(lambda (embed/url)
|
||||
`(div (h3 ,(number->string (web-cell-ref a-counter)))
|
||||
(a ([href ,(url->string
|
||||
(embed/url
|
||||
(lambda _
|
||||
; A new frame has been created
|
||||
(define last (web-cell-ref a-counter))
|
||||
; It is a child of the parent frame, so we can inspect the value
|
||||
(web-cell-mask a-counter (add1 last))
|
||||
; The new frame has been modified
|
||||
(generate))))])
|
||||
"+")))))
|
||||
(generate))))
|
||||
29
collects/web-server/prototype-web-server/newcont/file-box.ss
Normal file
29
collects/web-server/prototype-web-server/newcont/file-box.ss
Normal file
|
|
@ -0,0 +1,29 @@
|
|||
(module file-box mzscheme
|
||||
(require (lib "serialize.ss")
|
||||
(lib "contract.ss"))
|
||||
|
||||
(define-serializable-struct internal-file-box (path))
|
||||
(define file-box? internal-file-box?)
|
||||
|
||||
(define (file-box path default)
|
||||
(define fb (make-internal-file-box path))
|
||||
(unless (file-box-set? fb)
|
||||
(file-box-set! fb default))
|
||||
fb)
|
||||
|
||||
(define (file-box-set? fb)
|
||||
(with-handlers ([exn? (lambda _ #f)])
|
||||
(file-unbox fb)
|
||||
#t))
|
||||
|
||||
(define (file-unbox fb)
|
||||
(deserialize (call-with-input-file (internal-file-box-path fb) read)))
|
||||
(define (file-box-set! fb v)
|
||||
(with-output-to-file (internal-file-box-path fb) (lambda () (write (serialize v)))))
|
||||
|
||||
(provide/contract
|
||||
[file-box? (any/c . -> . boolean?)]
|
||||
[file-box (path? any/c . -> . file-box?)]
|
||||
[file-unbox (file-box? . -> . any/c)]
|
||||
[file-box-set? (file-box? . -> . boolean?)]
|
||||
[file-box-set! (file-box? any/c . -> . void)]))
|
||||
138
collects/web-server/prototype-web-server/newcont/freevars.ss
Normal file
138
collects/web-server/prototype-web-server/newcont/freevars.ss
Normal file
|
|
@ -0,0 +1,138 @@
|
|||
(module freevars mzscheme
|
||||
(require-for-template mzscheme)
|
||||
(require (lib "kerncase.ss" "syntax")
|
||||
(lib "list.ss")
|
||||
(lib "toplevel.ss" "syntax")
|
||||
(lib "plt-match.ss")
|
||||
(lib "stx.ss" "syntax")
|
||||
"util.ss")
|
||||
(provide free-vars)
|
||||
|
||||
;; free-vars: syntax -> (listof identifier)
|
||||
;; Find the free variables in an expression
|
||||
(define (free-vars stx)
|
||||
(kernel-syntax-case
|
||||
stx #f
|
||||
[(begin be ...)
|
||||
(free-vars* (syntax->list #'(be ...)))]
|
||||
[(begin0 be ...)
|
||||
(free-vars* (syntax->list #'(be ...)))]
|
||||
[(define-values (v ...) ve)
|
||||
(set-diff (free-vars #'ve)
|
||||
(syntax->list #'(v ...)))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(set-diff (free-vars #'ve)
|
||||
(syntax->list #'(v ...)))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(set-diff (free-vars #'ve)
|
||||
(syntax->list #'(v ...)))]
|
||||
[(set! v ve)
|
||||
(free-vars #'ve)]
|
||||
[(let-values ([(v ...) ve] ...) be ...)
|
||||
(union (free-vars* (syntax->list #'(ve ...)))
|
||||
(set-diff (free-vars* (syntax->list #'(be ...)))
|
||||
(apply append (map syntax->list (syntax->list #'((v ...) ...))))))]
|
||||
[(letrec-values ([(v ...) ve] ...) be ...)
|
||||
(set-diff (union (free-vars* (syntax->list #'(ve ...)))
|
||||
(free-vars* (syntax->list #'(be ...))))
|
||||
(apply append (map syntax->list (syntax->list #'((v ...) ...)))))]
|
||||
[(lambda formals be ...)
|
||||
(set-diff (free-vars* (syntax->list #'(be ...)))
|
||||
(formals-list #'formals))]
|
||||
[(case-lambda [formals be ...] ...)
|
||||
(apply union*
|
||||
(map (lambda (fs bes)
|
||||
(set-diff (free-vars* (syntax->list bes))
|
||||
(formals-list fs)))
|
||||
(syntax->list #'(formals ...))
|
||||
(syntax->list #'((be ...) ...))))]
|
||||
[(if te ce ae)
|
||||
(free-vars* (syntax->list #'(te ce ae)))]
|
||||
[(if te ce)
|
||||
(free-vars #`(if te ce (#%app void)))]
|
||||
[(quote datum)
|
||||
empty]
|
||||
[(quote-syntax datum)
|
||||
empty]
|
||||
[(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 ...) ...))))))]
|
||||
[(with-continuation-mark ke me be)
|
||||
(free-vars* (syntax->list #'(ke me be)))]
|
||||
[(#%expression . d)
|
||||
empty]
|
||||
[(#%app e ...)
|
||||
(free-vars* (syntax->list #'(e ...)))]
|
||||
[(#%top . v)
|
||||
empty]
|
||||
[(#%datum . d)
|
||||
empty]
|
||||
[(#%variable-reference . id)
|
||||
(let ([i-bdg (identifier-binding #'id)])
|
||||
(cond
|
||||
[(eqv? 'lexical (identifier-binding #'id))
|
||||
(list #'id)]
|
||||
[else
|
||||
empty]))]
|
||||
[id (identifier? #'id)
|
||||
(let ([i-bdg (identifier-binding #'id)])
|
||||
(cond
|
||||
[(eqv? 'lexical (identifier-binding #'id))
|
||||
(list #'id)]
|
||||
[else
|
||||
empty]))]
|
||||
[_
|
||||
(raise-syntax-error 'freevars "Dropped through:" stx)]))
|
||||
|
||||
;; free-vars*: (listof expr) -> (listof identifier)
|
||||
;; union the free variables that occur in several expressions
|
||||
(define (free-vars* exprs)
|
||||
(foldl
|
||||
(lambda (expr acc) (union (free-vars expr) acc))
|
||||
empty exprs))
|
||||
|
||||
;; union: (listof identifier) (listof identifier) -> (listof identifier)
|
||||
;; produce the set-theoretic union of two lists
|
||||
(define (union l1 l2)
|
||||
(cond
|
||||
[(null? l1) l2]
|
||||
[else (insert (car l1) (union (cdr l1) l2))]))
|
||||
|
||||
(define (union* . ll)
|
||||
(foldl union
|
||||
empty
|
||||
ll))
|
||||
|
||||
;; insert: symbol (listof identifier) -> (listof symbol)
|
||||
;; insert a symbol into a list without creating a duplicate
|
||||
(define (insert sym into)
|
||||
(unless (identifier? sym)
|
||||
(raise-syntax-error 'insert "Not identifier" sym))
|
||||
(cond
|
||||
[(null? into) (list sym)]
|
||||
[(bound-identifier=? sym (car into)) into]
|
||||
[else (cons (car into) (insert sym (cdr into)))]))
|
||||
|
||||
;; set-diff: (listof identifier) (listof identifier) -> (listof identifier)
|
||||
;; produce the set-theoretic difference of two lists
|
||||
(define (set-diff s1 s2)
|
||||
(cond
|
||||
[(null? s2) s1]
|
||||
[else (set-diff (sans s1 (car s2)) (cdr s2))]))
|
||||
|
||||
;; sans: (listof identifier) symbol -> (listof identifier)
|
||||
;; produce the list sans the symbol
|
||||
(define (sans s elt)
|
||||
(unless (identifier? elt)
|
||||
(raise-syntax-error 'sans "Not identifier" elt))
|
||||
(cond
|
||||
[(null? s) empty]
|
||||
[(bound-identifier=? (car s) elt)
|
||||
(cdr s)] ;; if we maintain the no-dupe invariant then we don't need to recur
|
||||
[else (cons (car s)
|
||||
(sans (cdr s) elt))])))
|
||||
35
collects/web-server/prototype-web-server/newcont/newcont.ss
Normal file
35
collects/web-server/prototype-web-server/newcont/newcont.ss
Normal file
|
|
@ -0,0 +1,35 @@
|
|||
(module newcont mzscheme
|
||||
(require-for-syntax (lib "etc.ss")
|
||||
(lib "labels.ss" "prototype-web-server")
|
||||
"util.ss"
|
||||
"elim-letrec.ss"
|
||||
"anormal.ss"
|
||||
"elim-callcc.ss"
|
||||
"defun.ss")
|
||||
(require (lib "abort-resume.ss" "prototype-web-server"))
|
||||
(require (only (lib "persistent-web-interaction.ss" "prototype-web-server")
|
||||
send/suspend/hidden
|
||||
send/suspend/url
|
||||
send/suspend/dispatch
|
||||
extract-proc/url embed-proc/url
|
||||
redirect/get
|
||||
start-servlet))
|
||||
(provide (rename lang-module-begin #%module-begin))
|
||||
(provide (all-from (lib "abort-resume.ss" "prototype-web-server"))
|
||||
(all-from-except mzscheme #%module-begin)
|
||||
send/suspend/hidden
|
||||
send/suspend/url
|
||||
send/suspend/dispatch
|
||||
extract-proc/url embed-proc/url
|
||||
redirect/get
|
||||
start-servlet)
|
||||
|
||||
(define-syntax lang-module-begin
|
||||
(make-lang-module-begin
|
||||
make-labeling
|
||||
(make-module-case/new-defs
|
||||
(make-define-case/new-defs
|
||||
(compose #;(lambda (stx) (values stx empty))
|
||||
defun
|
||||
elim-callcc
|
||||
(make-anormal-term elim-letrec-term)))))))
|
||||
194
collects/web-server/prototype-web-server/newcont/util.ss
Normal file
194
collects/web-server/prototype-web-server/newcont/util.ss
Normal file
|
|
@ -0,0 +1,194 @@
|
|||
(module util mzscheme
|
||||
(require-for-template mzscheme)
|
||||
(require (lib "kerncase.ss" "syntax")
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "toplevel.ss" "syntax")
|
||||
(lib "stx.ss" "syntax"))
|
||||
(provide (all-defined))
|
||||
|
||||
(define current-code-labeling
|
||||
(make-parameter
|
||||
(lambda (stx)
|
||||
(datum->syntax-object stx 'error))))
|
||||
|
||||
(define (generate-formal sym-name)
|
||||
(let ([name (datum->syntax-object #f (gensym sym-name))])
|
||||
(with-syntax ([(lambda (formal) ref-to-formal)
|
||||
(if (syntax-transforming?)
|
||||
(local-expand #`(lambda (#,name) #,name) 'expression empty)
|
||||
#`(lambda (#,name) #,name))])
|
||||
(values #'formal #'ref-to-formal))))
|
||||
|
||||
(define (formals-list stx)
|
||||
(syntax-case stx ()
|
||||
[v (identifier? #'v)
|
||||
(list #'v)]
|
||||
[(v ...)
|
||||
(syntax->list #'(v ...))]
|
||||
[(v ... . rv)
|
||||
(list* #'rv (syntax->list #'(v ...)))]))
|
||||
|
||||
(define ((make-define-case inner) stx)
|
||||
(syntax-case stx (define-values define-syntaxes define-values-for-syntax)
|
||||
[(define-values (v ...) ve)
|
||||
(with-syntax ([ve (inner #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(with-syntax ([ve (inner #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-syntaxes (v ...) ve)))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(with-syntax ([ve (inner #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values-for-syntax (v ...) ve)))]
|
||||
[_
|
||||
(raise-syntax-error 'define-case "Dropped through:" stx)]))
|
||||
|
||||
(define ((make-define-case/new-defs inner) stx)
|
||||
(let-values ([(nstx defs) (inner stx)])
|
||||
(append defs (list nstx))))
|
||||
|
||||
(define ((make-module-case/new-defs inner) stx)
|
||||
(syntax-case* stx (require provide require-for-syntax require-for-template) module-identifier=?
|
||||
[(require spec ...)
|
||||
(list stx)]
|
||||
[(provide spec ...)
|
||||
(list stx)]
|
||||
[(require-for-syntax spec ...)
|
||||
(list stx)]
|
||||
[(require-for-template spec ...)
|
||||
(list stx)]
|
||||
[_
|
||||
(inner stx)]))
|
||||
|
||||
(define ((make-module-case inner) stx)
|
||||
(syntax-case* stx (require provide require-for-syntax require-for-template) module-identifier=?
|
||||
[(require spec ...)
|
||||
stx]
|
||||
[(provide spec ...)
|
||||
stx]
|
||||
[(require-for-syntax spec ...)
|
||||
stx]
|
||||
[(require-for-template spec ...)
|
||||
stx]
|
||||
[_
|
||||
(inner stx)]))
|
||||
|
||||
(require-for-template (lib "abort-resume.ss" "prototype-web-server"))
|
||||
(define ((make-lang-module-begin make-labeling transform) stx)
|
||||
(syntax-case stx ()
|
||||
((mb forms ...)
|
||||
(with-syntax ([(pmb rfs body ...)
|
||||
(local-expand (quasisyntax/loc stx
|
||||
(#%plain-module-begin
|
||||
#,(syntax-local-introduce #'(require-for-syntax mzscheme))
|
||||
forms ...))
|
||||
'module-begin
|
||||
empty)])
|
||||
(let ([base-labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax-object->datum stx))))])
|
||||
(parameterize ([current-code-labeling
|
||||
(lambda (stx)
|
||||
(datum->syntax-object stx (base-labeling)))])
|
||||
(let ([new-defs (apply append (map transform (syntax->list #'(body ...))))])
|
||||
(quasisyntax/loc stx
|
||||
(pmb rfs
|
||||
#,@new-defs)))))))))
|
||||
|
||||
(define (bound-identifier-member? id ids)
|
||||
(ormap
|
||||
(lambda (an-id)
|
||||
(bound-identifier=? id an-id))
|
||||
ids))
|
||||
|
||||
;; Kernel Case Template
|
||||
(define (template stx)
|
||||
(kernel-syntax-case
|
||||
stx #f
|
||||
[(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 ...)))]
|
||||
[(define-values (v ...) ve)
|
||||
(with-syntax ([ve (template #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-syntaxes (v ...) ve)
|
||||
(with-syntax ([ve (template #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values (v ...) ve)))]
|
||||
[(define-values-for-syntax (v ...) ve)
|
||||
(with-syntax ([ve (template #'ve)])
|
||||
(syntax/loc stx
|
||||
(define-values-for-syntax (v ...) ve)))]
|
||||
[(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 ...)))]
|
||||
[(lambda formals be ...)
|
||||
(with-syntax ([(be ...) (map template (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(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)))]
|
||||
[(if te ce)
|
||||
(template (syntax/loc stx (if te ce (#%app void))))]
|
||||
[(quote datum)
|
||||
stx]
|
||||
[(quote-syntax datum)
|
||||
stx]
|
||||
[(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)
|
||||
(with-syntax ([(se ...) (map template (syntax->list #'(se ...)))]
|
||||
[(ve ...) (map template (syntax->list #'(ve ...)))]
|
||||
[(be ...) (map template (syntax->list #'(be ...)))])
|
||||
(syntax/loc stx
|
||||
(letrec-syntaxes+values ([(sv ...) se] ...)
|
||||
([(vv ...) ve] ...)
|
||||
be ...)))]
|
||||
[(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)))]
|
||||
[(#%expression . d)
|
||||
stx]
|
||||
[(#%app e ...)
|
||||
(with-syntax ([(e ...) (map template (syntax->list #'(e ...)))])
|
||||
(syntax/loc stx
|
||||
(#%app e ...)))]
|
||||
[(#%top . v)
|
||||
stx]
|
||||
[(#%datum . d)
|
||||
stx]
|
||||
[(#%variable-reference . v)
|
||||
stx]
|
||||
[id (identifier? #'id)
|
||||
stx]
|
||||
[_
|
||||
(raise-syntax-error 'kerncase "Dropped through:" stx)])))
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
(module web-cell-component mzscheme
|
||||
(require (lib "web-cells.ss" "newcont"))
|
||||
(provide define-component)
|
||||
|
||||
(define-syntax define-component
|
||||
(syntax-rules (define)
|
||||
[(_ (include-name id formals embed/url) body ...)
|
||||
(define include-name
|
||||
(lambda formals
|
||||
(let/cc k
|
||||
(define (id)
|
||||
(k
|
||||
(lambda (embed/url)
|
||||
body ...)))
|
||||
(id))))])))
|
||||
|
|
@ -0,0 +1,86 @@
|
|||
(module web-cells mzscheme
|
||||
(require (lib "closure.ss" "prototype-web-server")
|
||||
(lib "serialize.ss")
|
||||
(lib "list.ss")
|
||||
(lib "plt-match.ss")
|
||||
(lib "contract.ss"))
|
||||
;; Implementation: Have a distinguished frame variable that is read and captured by send/suspend,
|
||||
;; installed on invocations of continuations by the server (and NOT from other continuation invocations)
|
||||
|
||||
;; Data types
|
||||
(define-serializable-struct primitive-wc (id))
|
||||
(define-serializable-struct frame (env))
|
||||
|
||||
;; Environment
|
||||
(define empty-env empty)
|
||||
(define env-lookup
|
||||
(match-lambda*
|
||||
[(list id (list))
|
||||
(error 'web-cell "Undefined web-cell: ~e" id)]
|
||||
[(list id (list-rest (list-rest a-id a-val) env))
|
||||
(if (eq? id a-id)
|
||||
a-val
|
||||
(env-lookup id env))]))
|
||||
(define env-replace
|
||||
(match-lambda*
|
||||
[(list id val (list))
|
||||
(list (cons id val))]
|
||||
[(list id val (list-rest (list-rest a-id a-val) env))
|
||||
(if (eq? id a-id)
|
||||
(list* (cons id val) env)
|
||||
(list* (cons a-id a-val)
|
||||
(env-replace id val env)))]))
|
||||
|
||||
;; Frames
|
||||
(define *wc-frame* (make-thread-cell (make-frame empty-env) #t))
|
||||
(define (current-frame) (thread-cell-ref *wc-frame*))
|
||||
(define (update-frame! nf) (thread-cell-set! *wc-frame* nf))
|
||||
|
||||
;; Web Cell Sets
|
||||
(define web-cell-set? frame?)
|
||||
(define (capture-web-cell-set) (current-frame))
|
||||
(define (restore-web-cell-set! wcs) (update-frame! wcs))
|
||||
|
||||
(provide/contract
|
||||
[web-cell-set? (any/c . -> . boolean?)]
|
||||
[capture-web-cell-set (-> web-cell-set?)]
|
||||
[restore-web-cell-set! (web-cell-set? . -> . void)])
|
||||
|
||||
;; Web Cells
|
||||
(define next-web-cell-id
|
||||
(let ([i (box 0)])
|
||||
(lambda ()
|
||||
(begin0 (unbox i)
|
||||
(set-box! i (add1 (unbox i)))))))
|
||||
|
||||
(define web-cell? primitive-wc?)
|
||||
|
||||
(define-syntax make-web-cell
|
||||
(syntax-rules ()
|
||||
[(_ default)
|
||||
(make-web-cell* (closure->deserialize-name (lambda () 'web-cell))
|
||||
default)]))
|
||||
(define (make-web-cell* label default)
|
||||
(define id (next-web-cell-id))
|
||||
(define key (string->symbol (format "~a-~a" label id)))
|
||||
(define wc (make-primitive-wc key))
|
||||
(web-cell-mask wc default)
|
||||
wc)
|
||||
|
||||
(define (web-cell-ref pwc)
|
||||
(env-lookup (primitive-wc-id pwc)
|
||||
(frame-env (current-frame))))
|
||||
|
||||
(define (web-cell-mask wc nv)
|
||||
(update-frame!
|
||||
(make-frame
|
||||
(env-replace (primitive-wc-id wc) nv
|
||||
(frame-env (current-frame))))))
|
||||
|
||||
(provide make-web-cell
|
||||
make-web-cell*)
|
||||
(provide/contract
|
||||
#;[make-web-cell* (symbol? any/c . -> . web-cell?)]
|
||||
[web-cell? (any/c . -> . boolean?)]
|
||||
[web-cell-ref (web-cell? . -> . any/c)]
|
||||
[web-cell-mask (web-cell? any/c . -> . void)]))
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
(module web-param mzscheme
|
||||
(require (lib "closure.ss" "prototype-web-server")
|
||||
(lib "list.ss"))
|
||||
(provide make-web-parameter
|
||||
next-web-parameter-id
|
||||
web-parameter?
|
||||
web-parameterize)
|
||||
|
||||
(define (web-parameter? any)
|
||||
(and (procedure? any)
|
||||
(procedure-arity-includes? any 0)
|
||||
(procedure-arity-includes? any 2)))
|
||||
|
||||
(define next-web-parameter-id
|
||||
(let ([i (box 0)])
|
||||
(lambda ()
|
||||
(begin0 (unbox i)
|
||||
(set-box! i (add1 (unbox i)))))))
|
||||
|
||||
; This is syntax so that the web-language transformations can occur.
|
||||
(define-syntax make-web-parameter
|
||||
(syntax-rules ()
|
||||
[(_ default)
|
||||
; Key is a lambda, the defunctionalization process will turn it into a serializable value with the module's label embedded in it, that way the parameters are not guessable AND sensitive to changes in the source
|
||||
; I don't like the assumption of deserialization though, but I have to do this grossness because w-c-m uses equal? and post-deserialization, the two lambdas are not equal.
|
||||
(let* ([id (next-web-parameter-id)]
|
||||
[label (closure->deserialize-name (lambda () 'web-param))]
|
||||
[key (string->symbol (format "~a-~a" label id))])
|
||||
(case-lambda
|
||||
[()
|
||||
(let ([cur
|
||||
(continuation-mark-set->list
|
||||
(current-continuation-marks)
|
||||
key)])
|
||||
(if (empty? cur)
|
||||
default
|
||||
(first cur)))]
|
||||
[(v thunk)
|
||||
(with-continuation-mark key v (thunk))]))]))
|
||||
|
||||
(define-syntax web-parameterize/values
|
||||
(syntax-rules ()
|
||||
[(_ () e ...)
|
||||
(begin e ...)]
|
||||
[(_ ([wp v]) e ...)
|
||||
(wp v (lambda () e ...))]
|
||||
[(_ ([fwp fv] [wp v] ...) e ...)
|
||||
(web-parameterize/values ([fwp fv]) (web-parameterize/values ([wp v] ...) e ...))]))
|
||||
|
||||
(define-syntax (web-parameterize stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ([wp ve] ...) e ...)
|
||||
(with-syntax ([(v ...) (generate-temporaries (syntax->list #'(ve ...)))])
|
||||
#'(let ([v ve] ...)
|
||||
(web-parameterize/values ([wp v] ...) e ...)))])))
|
||||
Loading…
Reference in New Issue
Block a user