Removing old interaction languages and compilers
svn: r6301
This commit is contained in:
Jay McCarthy
parent
be9259d5ac
commit
ac170ef52e
|
|
@ -1,4 +0,0 @@
|
|||
(module client mzscheme
|
||||
(require "abort-resume.ss")
|
||||
(provide dispatch-start
|
||||
dispatch))
|
||||
|
|
@ -1,202 +0,0 @@
|
|||
(module defunctionalize mzscheme
|
||||
(require (lib "list.ss")
|
||||
"closure.ss"
|
||||
"syntax-utils.ss")
|
||||
(require-for-template mzscheme)
|
||||
(provide defunctionalize-definition
|
||||
defunctionalize)
|
||||
|
||||
;; **************************************************
|
||||
;; LANGUAGE
|
||||
;;
|
||||
;; program ::= definition* expr
|
||||
;;
|
||||
;; definition ::= (define-values (var) expr)
|
||||
;;
|
||||
;; expr ::= w
|
||||
;; | E[redex]
|
||||
;;
|
||||
;; redex ::= (if w expr)
|
||||
;; | (if w expr expr)
|
||||
;; | (#%app w w...)
|
||||
;;
|
||||
;; E ::= []
|
||||
;; | (let-values ([(f) (lambda (var) expr)])
|
||||
;; (#%app f (w-c-m f E)))
|
||||
;;
|
||||
;; w ::= var | (#%top . var) | value
|
||||
;;
|
||||
;; value ::= (#%datum . datum)
|
||||
;; | (lambda (var ...) expr)
|
||||
|
||||
;; defunctionalize-definition: definition (-> symbol) -> (listof definition)
|
||||
;; remove lambdas from a definition
|
||||
(define (defunctionalize-definition def labeling)
|
||||
(syntax-case def ()
|
||||
[(define-values (var ...) expr)
|
||||
(with-syntax ([expr (recertify #'expr def)])
|
||||
(let-values ([(new-expr defs) (defunctionalize #'expr labeling)])
|
||||
(append defs (list #`(define-values (var ...) #,new-expr)))))]
|
||||
[else
|
||||
(raise-syntax-error #f "defunctionalize-definition dropped through" def)]))
|
||||
|
||||
;; defunctionalize: expr (-> symbol) -> (values expr (listof definition))
|
||||
;; remove lambdas from an expression
|
||||
(define (defunctionalize expr labeling)
|
||||
(syntax-case expr (if #%app lambda let-values #%top #%datum with-continuation-mark quote)
|
||||
[(if test-expr csq-expr)
|
||||
(with-syntax ([(tst-expr csq-expr) (recertify* (list #'tst-expr #'csq-expr) expr)])
|
||||
(let-values ([(new-test-expr test-defs) (defunctionalize #'test-expr labeling)]
|
||||
[(new-csq-expr csq-defs) (defunctionalize #'csq-expr labeling)])
|
||||
(values
|
||||
#`(if #,new-test-expr #,new-csq-expr)
|
||||
(append test-defs csq-defs))))]
|
||||
[(if test-expr csq-expr alt-expr)
|
||||
(with-syntax ([(tst-expr csq-expr alt-expr) (recertify* (list #'tst-expr #'csq-expr #'alt-expr) expr)])
|
||||
(let-values ([(new-test-expr test-defs) (defunctionalize #'test-expr labeling)]
|
||||
[(new-csq-expr csq-defs) (defunctionalize #'csq-expr labeling)]
|
||||
[(new-alt-expr alt-defs) (defunctionalize #'alt-expr labeling)])
|
||||
(values #`(if #,new-test-expr #,new-csq-expr #,new-alt-expr)
|
||||
(append test-defs csq-defs alt-defs))))]
|
||||
[(#%app exprs ...)
|
||||
(with-syntax ([(exprs ...) (recertify* (syntax->list #'(exprs ...)) expr)])
|
||||
(let-values ([(new-exprs defs) (defunctionalize* (syntax->list #'(exprs ...)) labeling)])
|
||||
(values
|
||||
#`(#%app #,@new-exprs)
|
||||
defs)))]
|
||||
[(let-values ([(f) rhs])
|
||||
(#%app f-apply (with-continuation-mark ignore-key f-mark body-expr)))
|
||||
(with-syntax ([(rhs f-apply ignore-key f-mark body-expr)
|
||||
(recertify* (syntax->list #'(rhs f-apply ignore-key f-mark body-expr)) expr)])
|
||||
(let-values ([(new-rhs rhs-defs) (defunctionalize #'rhs labeling)]
|
||||
[(new-body-expr body-defs) (defunctionalize #'body-expr labeling)])
|
||||
(values
|
||||
#`(let ([f #,new-rhs])
|
||||
(f-apply (with-continuation-mark ignore-key f-mark #,new-body-expr)))
|
||||
(append rhs-defs body-defs))))]
|
||||
[(let-values ([(f) rhs]) (#%app f-apply body-expr))
|
||||
(with-syntax ([(rhs f-apply body-expr) (recertify* (syntax->list #'(rhs f-apply body-expr) expr))])
|
||||
(let-values ([(new-rhs rhs-defs) (defunctionalize #'rhs labeling)]
|
||||
[(new-body-expr body-defs) (defunctionalize #'body-expr labeling)])
|
||||
(values
|
||||
#`(let ([f #,new-rhs])
|
||||
(f-apply #,new-body-expr))
|
||||
(append rhs-defs body-defs))))]
|
||||
[(lambda (formals ...) body-expr)
|
||||
(with-syntax ([body-expr (recertify #'body-expr expr)])
|
||||
(let-values ([(new-body-expr body-defs) (defunctionalize #'body-expr labeling)])
|
||||
(let ([fvars (free-vars expr)]
|
||||
[tag (labeling)])
|
||||
(let-values ([(make-CLOSURE closure-definitions)
|
||||
(make-closure-definition-syntax tag fvars
|
||||
#`(lambda (formals ...) #,new-body-expr))])
|
||||
(values
|
||||
(if (null? fvars)
|
||||
#`(#,make-CLOSURE)
|
||||
#`(#,make-CLOSURE (lambda () (values #,@fvars))))
|
||||
(append body-defs
|
||||
closure-definitions))))))]
|
||||
[(with-continuation-mark safe-call? b-val body-expr)
|
||||
(with-syntax ([body-expr (recertify #'body-expr expr)])
|
||||
(let-values ([(new-body-expr body-defs) (defunctionalize #'body-expr labeling)])
|
||||
(values
|
||||
#`(with-continuation-mark safe-call? b-val #,new-body-expr)
|
||||
body-defs)))]
|
||||
[(#%top . var) (values expr '())]
|
||||
[(#%datum . var) (values expr '())]
|
||||
[(quote datum) (values expr '())]
|
||||
[var (identifier? #'var) (values expr '())]
|
||||
[_else
|
||||
(raise-syntax-error #f "defunctionalize: dropped through" expr)]))
|
||||
|
||||
;; defunctionalize*: (listof expr) (-> symbol) -> (values (listof expr) (listof definition))
|
||||
;; remove lambdas from a whole list of expressions
|
||||
(define (defunctionalize* exprs labeling)
|
||||
(cond
|
||||
[(null? exprs) (values '() '())]
|
||||
[else
|
||||
(let-values ([(first-new-expr first-defs) (defunctionalize (car exprs) labeling)]
|
||||
[(rest-new-exprs rest-defs) (defunctionalize* (cdr exprs) labeling)])
|
||||
(values
|
||||
(cons first-new-expr rest-new-exprs)
|
||||
(append first-defs rest-defs)))]))
|
||||
|
||||
;; free-vars: expr -> (listof identifier)
|
||||
;; Find the free variables in an expression
|
||||
(define (free-vars expr)
|
||||
(syntax-case expr (if #%app lambda let #%top #%datum with-continuation-mark quote)
|
||||
[(if test-expr csq-expr)
|
||||
(union (free-vars #'test-expr)
|
||||
(free-vars #'csq-expr))]
|
||||
[(if test-expr csq-expr alt-expr)
|
||||
(union (free-vars #'test-expr)
|
||||
(union (free-vars #'csq-expr)
|
||||
(free-vars #'alt-expr)))]
|
||||
[(#%app exprs ...)
|
||||
(free-vars* (syntax->list #'(exprs ...)))]
|
||||
[(let-values ([(f) rhs])
|
||||
(#%app f-apply (with-continuation-mark ignore-key f-mark body-expr)))
|
||||
;; (and (bound-identifier=? #'f #'f-apply) (bound-identifier=? #'f #'f-mark))
|
||||
(union (free-vars #'rhs)
|
||||
(set-diff (free-vars #'body-expr) (list #'f)))]
|
||||
|
||||
[(let-values ([(f) rhs]) (#%app f-apply body-expr))
|
||||
(union (free-vars #'rhs)
|
||||
(set-diff (free-vars #'body-expr) (list #'f)))]
|
||||
|
||||
[(lambda (formals ...) body-expr)
|
||||
(set-diff (free-vars #'body-expr) (syntax->list #'(formals ...)))]
|
||||
[(with-continuation-mark safe-call? b-val body-expr)
|
||||
(free-vars #'body-expr)]
|
||||
[(#%top . var) '()]
|
||||
[(#%datum . var) '()]
|
||||
[(quote datum) '()]
|
||||
[var (identifier? #'var)
|
||||
(let ([i-bdg (identifier-binding #'var)])
|
||||
(cond
|
||||
[(eqv? 'lexical (identifier-binding #'var))
|
||||
(list #'var)]
|
||||
[else '()]))]
|
||||
[_else
|
||||
(raise-syntax-error #f "free-vars: dropped through" expr)]))
|
||||
|
||||
;; 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))
|
||||
'() 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))]))
|
||||
|
||||
;; insert: symbol (listof identifier) -> (listof symbol)
|
||||
;; insert a symbol into a list without creating a duplicate
|
||||
(define (insert sym into)
|
||||
(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)
|
||||
(cond
|
||||
[(null? s) '()]
|
||||
[(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))]))
|
||||
)
|
||||
|
||||
|
|
@ -1,116 +0,0 @@
|
|||
(module elim-call-cc mzscheme
|
||||
(require "syntax-utils.ss")
|
||||
(require-for-template "abort-resume.ss" mzscheme)
|
||||
(provide elim-call/cc-from-definition
|
||||
elim-call/cc)
|
||||
|
||||
;; **************************************************
|
||||
;; LANGUAGE
|
||||
;;
|
||||
;; program ::= definition* expr
|
||||
;;
|
||||
;; definition ::= (define-values (var) expr)
|
||||
;;
|
||||
;; expr ::= w
|
||||
;; | (if w expr)
|
||||
;; | (if w expr expr)
|
||||
;; | (#%app w expr) ;where expr != w
|
||||
;; | (#%app w w ...)
|
||||
;; | (#%app call/cc w)
|
||||
;;
|
||||
;; w ::= var | (#%top . var) | value
|
||||
;; value ::= (#%datum . datum)
|
||||
;; | (lambda (var ...) expr)
|
||||
|
||||
;; id: alpha -> alpha
|
||||
(define (id x) x)
|
||||
|
||||
;; elim-call/cc: expr -> expr
|
||||
;; eliminate call/cc from an expression
|
||||
(define (elim-call/cc expr)
|
||||
(elim-call/cc/mark expr id))
|
||||
|
||||
;; elim-call/cc/mark: expr (expr -> expr) -> expr
|
||||
;; eliminate call/cc from an expression given a mark frame function
|
||||
(define (elim-call/cc/mark expr markit)
|
||||
(syntax-case expr (if #%app call/cc #%top #%datum lambda quote)
|
||||
[(if w e)
|
||||
(with-syntax ([(w e) (recertify* (list #'w #'e) expr)])
|
||||
(markit #`(if #,(elim-call/cc #'w) #,(elim-call/cc #'e))))]
|
||||
[(if w e0 e1)
|
||||
(with-syntax ([(w e0 e1) (recertify* (list #'w #'e0 #'e1) expr)])
|
||||
(markit #`(if #,(elim-call/cc #'w)
|
||||
#,(elim-call/cc #'e0)
|
||||
#,(elim-call/cc #'e1))))]
|
||||
[(#%app call/cc w)
|
||||
(with-syntax ([w (recertify #'w expr)])
|
||||
(let-values ([(cm ref-to-cm) (generate-formal 'current-marks)]
|
||||
[(x ref-to-x) (generate-formal 'x)])
|
||||
(markit #`(#%app #,(elim-call/cc #'w)
|
||||
(#%app (lambda (#,cm)
|
||||
(lambda (#,x)
|
||||
(#%app abort
|
||||
(lambda () (#%app resume #,ref-to-cm (#%app list #,ref-to-x))))))
|
||||
(#%app activation-record-list))))))]
|
||||
;; this is (w e) where e is not a w. (w w) handled in next case.
|
||||
;; m00.4 in persistent-interaction-tests.ss tests this distinction
|
||||
[(#%app w (#%app . stuff))
|
||||
(with-syntax ([e #'(#%app . stuff)])
|
||||
(with-syntax ([(w e) (recertify* (list #'w #'e) expr)])
|
||||
(syntax-case #'w (lambda)
|
||||
[(lambda (formals ...) body)
|
||||
(let ([w-prime (datum->syntax-object #f (gensym 'f))])
|
||||
#`(let-values ([(#,w-prime) #,(elim-call/cc #'w)])
|
||||
#,(markit
|
||||
#`(#%app #,w-prime
|
||||
#,(elim-call/cc/mark
|
||||
#'e
|
||||
(lambda (x)
|
||||
#`(with-continuation-mark the-cont-key #,w-prime #,x)))))))]
|
||||
[_else
|
||||
(let ([w-prime (elim-call/cc #'w)])
|
||||
(markit
|
||||
#`(#%app #,w-prime
|
||||
#,(elim-call/cc/mark
|
||||
#'e
|
||||
(lambda (x)
|
||||
#`(with-continuation-mark the-cont-key #,w-prime #,x))))))])))]
|
||||
[(#%app w rest ...)
|
||||
(with-syntax ([(w rest ...) (recertify* (syntax->list #'(w rest ...)) expr)])
|
||||
(markit
|
||||
#`(with-continuation-mark safe-call? #f
|
||||
(#%app #,(mark-lambda-as-safe (elim-call/cc #'w))
|
||||
#,@(map
|
||||
(lambda (an-expr)
|
||||
(mark-lambda-as-safe
|
||||
(elim-call/cc
|
||||
an-expr)))
|
||||
(syntax->list #'(rest ...)))))))]
|
||||
[(#%top . var) expr]
|
||||
[(#%datum . d) expr]
|
||||
[(lambda (formals ...) body)
|
||||
(with-syntax ([body (recertify #'body expr)])
|
||||
#`(lambda (formals ...) #,(elim-call/cc #'body)))]
|
||||
[(quote datum) expr]
|
||||
[x (symbol? (syntax-object->datum #'x)) expr]
|
||||
[_else
|
||||
(raise-syntax-error #f "elim-call/cc/mark dropped through" expr)]))
|
||||
|
||||
;; elim-call/cc-from-definition: definition -> definition
|
||||
;; produce a transformed defintion
|
||||
(define (elim-call/cc-from-definition def)
|
||||
(syntax-case def ()
|
||||
[(define-values (var ...) expr)
|
||||
#`(define-values (var ...) #,(mark-lambda-as-safe (elim-call/cc #'expr)))]
|
||||
[else
|
||||
(raise-syntax-error #f "elim-call/cc-from-definition dropped through" def)]))
|
||||
|
||||
;; 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)
|
||||
[(lambda (formals ...) body)
|
||||
#`(lambda (formals ...)
|
||||
(with-continuation-mark safe-call? #t
|
||||
body))]
|
||||
[_else w])))
|
||||
|
|
@ -1,148 +0,0 @@
|
|||
(module elim-letrec mzscheme
|
||||
(require "syntax-utils.ss")
|
||||
(require-for-template "abort-resume.ss" mzscheme)
|
||||
(provide elim-letrec
|
||||
elim-letrec-from-definition)
|
||||
|
||||
|
||||
;; **************************************************
|
||||
;; SOURCE LANGUAGE
|
||||
;;
|
||||
;; program ::= definition* expr
|
||||
;;
|
||||
;; definition ::= (define-values (var ...) expr)
|
||||
;;
|
||||
;; expr ::= var
|
||||
;; | (letrec-values ([(var) expr] ...) expr)
|
||||
;; | (lambda (var ...) expr)
|
||||
;; | (if expr expr)
|
||||
;; | (if expr expr expr)
|
||||
;; | (let-values ([(var ...)] expr) expr)
|
||||
;; | (#%app expr ...)
|
||||
;; | (#%datum . datum)
|
||||
;; | (#%top . var)
|
||||
;; | (begin expr ...)
|
||||
;;
|
||||
;; NOTES: (1) Assumes fully expanded code.
|
||||
;; (2) For now just single vars on the RHS of a letrec values.
|
||||
|
||||
;; **************************************************
|
||||
;; TARGET LANGUAGE
|
||||
;;
|
||||
;; program ::= definition* expr
|
||||
;;
|
||||
;; definition ::= (define-values (var ...) expr)
|
||||
;;
|
||||
;; expr ::= var
|
||||
;; | (lambda (var ...) expr ...)
|
||||
;; | (if expr expr)
|
||||
;; | (if expr expr expr)
|
||||
;; | (let-values ([(var ...)] expr) expr)
|
||||
;; | (#%app expr ...)
|
||||
;; | (#%datum . datum)
|
||||
;; | (#%top . var)
|
||||
;; | (begin expr ...)
|
||||
|
||||
;; elim-letrec-from-definition: definition -> expr
|
||||
(define (elim-letrec-from-definition def)
|
||||
(syntax-case def (define-values)
|
||||
[(define-values (ids ...) body-expr)
|
||||
#`(define-values (ids ...) #,(elim-letrec #'body-expr))]
|
||||
[_else
|
||||
(raise-syntax-error #f "elim-letrec-from-definition: dropped through" def)]))
|
||||
|
||||
;; elim-letrec: source-expr -> target-expr
|
||||
;; eliminate all occurences of letrec-values from the source expression
|
||||
(define (elim-letrec src-expr)
|
||||
(elim-letrec/ids src-expr '()))
|
||||
|
||||
;; elim-letrec/ids: source-expr (listof identifier) -> target-expr
|
||||
;; eliminate letrec-values and make substitutions for the indicated ids
|
||||
;; substitute x ---> (unbox x), (set! x expr) (set-box! x expr)
|
||||
(define (elim-letrec/ids expr ids)
|
||||
(syntax-case expr (lambda letrec-values if let-values #%app #%datum #%top quote begin set!)
|
||||
[(letrec-values ([(vars) rhss] ...) body-expr)
|
||||
(with-syntax ([(body-expr rhss ...) (recertify* (syntax->list #'(body-expr rhss ...)) expr)])
|
||||
(let ([ids (append (syntax->list #'(vars ...)) ids)])
|
||||
(with-syntax ([(new-rhss ...)
|
||||
(map
|
||||
(lambda (rhs)
|
||||
(elim-letrec/ids rhs ids))
|
||||
(syntax->list #'(rhss ...)))]
|
||||
[new-body (elim-letrec/ids #'body-expr ids)])
|
||||
#`(let-values ([(vars ...) (#%app values
|
||||
#,@(map
|
||||
(lambda (x) #'(#%app box the-undef))
|
||||
(syntax->list #'(vars ...))))])
|
||||
(begin
|
||||
(#%app set-box! vars new-rhss) ...
|
||||
new-body)))))]
|
||||
[(letrec-values . anything)
|
||||
(raise-syntax-error #f "elim-letrec: Not all letrec-values-expressions supported" expr)]
|
||||
[(lambda (formals ...) body-expr ...)
|
||||
(with-syntax ([(body-expr ...) (recertify* (syntax->list #'(body-expr ...)) expr)])
|
||||
#`(lambda (formals ...)
|
||||
#,@(map
|
||||
(lambda (an-expr)
|
||||
(elim-letrec/ids an-expr ids))
|
||||
(syntax->list #'(body-expr ...)))))]
|
||||
[(lambda . anything)
|
||||
(raise-syntax-error #f "elim-letrec: Not all lambda-expressions supported" expr)]
|
||||
[(if tst-expr csq-expr)
|
||||
(with-syntax ([(tst-expr csq-expr) (recertify* (list #'tst-expr #'csq-expr) expr)])
|
||||
#`(if #,(elim-letrec/ids #'tst-expr ids)
|
||||
#,(elim-letrec/ids #'csq-expr ids)))]
|
||||
[(if tst-expr csq-expr alt-expr)
|
||||
(with-syntax ([(tst-expr csq-expr alt-expr) (recertify* (list #'tst-expr #'csq-expr #'alt-expr) expr)])
|
||||
#`(if #,(elim-letrec/ids #'tst-expr ids)
|
||||
#,(elim-letrec/ids #'csq-expr ids)
|
||||
#,(elim-letrec/ids #'alt-expr ids)))]
|
||||
[(let-values ([(varss ...) rhs-exprs] ...) body-exprs ...)
|
||||
(with-syntax ([(rhs-exprs ...) (recertify* (syntax->list #'(rhs-exprs ...)) expr)]
|
||||
[(body-exprs ...) (recertify* (syntax->list #'(body-exprs ...)) expr)])
|
||||
(let ([elim-letrec* (lambda (an-expr) (elim-letrec/ids an-expr ids))])
|
||||
(with-syntax ([(new-rhs-exprs ...)
|
||||
(map elim-letrec* (syntax->list #'(rhs-exprs ...)))]
|
||||
[(new-body-exprs ...)
|
||||
(map elim-letrec* (syntax->list #'(body-exprs ...)))])
|
||||
#`(let-values ([(varss ...) new-rhs-exprs] ...) new-body-exprs ...))))]
|
||||
[(#%app expr-rator expr-rands ...)
|
||||
(with-syntax ([(expr-rator expr-rands ...) (recertify* (syntax->list #'(expr-rator expr-rands ...)) expr)])
|
||||
#`(#%app #,(elim-letrec/ids #'expr-rator ids)
|
||||
#,@(map
|
||||
(lambda (expr-rand)
|
||||
(elim-letrec/ids expr-rand ids))
|
||||
(syntax->list #'(expr-rands ...)))))]
|
||||
[(set! id rhs-expr)
|
||||
(with-syntax ([id (recertify #'id expr)])
|
||||
(if (bound-identifier-member? #'id ids)
|
||||
#`(#%app set-box! id #,(elim-letrec/ids #'rhs-expr ids))
|
||||
#`(set! id #,(elim-letrec/ids #'rhs-expr ids))))]
|
||||
[(#%datum . datum) expr]
|
||||
[(#%top . var) expr]
|
||||
[(begin rest-expr ...)
|
||||
(with-syntax ([(rest-expr ...) (recertify* (syntax->list #'(rest-expr ...)) expr)])
|
||||
#`(begin
|
||||
#,@(map
|
||||
(lambda (an-expr)
|
||||
(elim-letrec/ids an-expr ids))
|
||||
(syntax->list #'(rest-expr ...)))))]
|
||||
[(quote datum) expr]
|
||||
[id
|
||||
(if (bound-identifier-member? #'id ids)
|
||||
#'(#%app unbox id)
|
||||
#'id)]
|
||||
[_else
|
||||
(raise-syntax-error #f "elim-letrec: unsupported form" expr)]))
|
||||
|
||||
(define myprint printf)
|
||||
|
||||
;; bound-identifier-member?: identifier (listof identifier) -> boolean
|
||||
;; is the given identifier in the list according to bound-identifier=?
|
||||
(define (bound-identifier-member? id ids)
|
||||
(ormap
|
||||
(lambda (an-id)
|
||||
(bound-identifier=? id an-id))
|
||||
ids))
|
||||
)
|
||||
|
||||
|
|
@ -1,88 +0,0 @@
|
|||
(module expander mzscheme
|
||||
(require "abort-resume.ss")
|
||||
(require-for-syntax (lib "kerncase.ss" "syntax")
|
||||
"normalizer.ss"
|
||||
"elim-call-cc.ss")
|
||||
(provide lang-module-begin)
|
||||
(provide (all-from "abort-resume.ss"))
|
||||
|
||||
;; lang-module-begin
|
||||
;; Does the normal module-begin stuff, except it hands off all
|
||||
;; module forms to a collect macro.
|
||||
(define-syntax (lang-module-begin stx)
|
||||
(syntax-case stx ()
|
||||
[(_ form ...)
|
||||
#`(#%plain-module-begin
|
||||
;#,(datum->syntax-object stx '(require-for-syntax mzscheme))
|
||||
(collect () (form ...)))]))
|
||||
|
||||
;; collect
|
||||
;; (collect (def/expr ...) (module-form ...))
|
||||
;; collect expands each module-form until it can recognize what kind of form it is.
|
||||
;; If it's a define-syntaxes, require, require-for-syntax, or provide form,
|
||||
;; it lets it "pass through" the collect macro to be executed by the primitive module
|
||||
;; expander. If it's a define-values form, it expands the body and then reconstructs a
|
||||
;; define-values form to put in the def/exprs list. If it's any other kind of form, it
|
||||
;; fully expands the form and puts it on the def/exprs list.
|
||||
;;
|
||||
;; The fully expanded definitions and expressions are then passed (in the original
|
||||
;; order) to the transform macro.
|
||||
(define-syntax (collect stx)
|
||||
(define (module-identifier-member id ids)
|
||||
(cond [(null? ids) #f]
|
||||
[(module-identifier=? id (car ids)) ids]
|
||||
[else (module-identifier-member id (cdr ids))]))
|
||||
(syntax-case stx ()
|
||||
[(_ rev-def/exprs (form0 . forms))
|
||||
(let ([expand-context (syntax-local-context)]
|
||||
[stop-list (list*
|
||||
#'require
|
||||
#'require-for-syntax
|
||||
#'provide
|
||||
(kernel-form-identifier-list #'here))])
|
||||
(let ([e-form0 (local-expand #'form0 expand-context stop-list)])
|
||||
(syntax-case e-form0 (begin define-values)
|
||||
[(keyword . _)
|
||||
(and (identifier? #'keyword)
|
||||
(module-identifier-member #'keyword
|
||||
(list #'require #'require-for-syntax
|
||||
#'provide #'define-syntaxes)))
|
||||
#`(begin #,e-form0 (collect rev-def/exprs forms))]
|
||||
[(begin e-form ...)
|
||||
#`(collect rev-def/exprs (e-form ... . forms))]
|
||||
[(define-values (id ...) expr)
|
||||
(andmap identifier? (syntax->list #'(id ...)))
|
||||
(let ([e-expr (local-expand #'expr 'expression (list #'#%top))])
|
||||
#`(begin
|
||||
(collect [(define-values (id ...) #,e-expr) . rev-def/exprs]
|
||||
forms)))]
|
||||
[expr
|
||||
(let ([e-expr (local-expand #'expr 'expression (list #'#%top))])
|
||||
#`(collect [#,e-expr . rev-def/exprs] forms))])))]
|
||||
[(_ rev-def/exprs ())
|
||||
(with-syntax ([(def/expr ...) (reverse (syntax->list #'rev-def/exprs))])
|
||||
#'(transform () (def/expr ...)))]))
|
||||
|
||||
;; **********************************************************************
|
||||
;; **********************************************************************
|
||||
|
||||
;; transform
|
||||
;; This macro is where you put your transformations. Each def/expr is core mzscheme.
|
||||
;; Furthermore, no def/expr is a define-syntaxes, require etc form.
|
||||
(define-syntax (transform stx)
|
||||
(syntax-case stx (define-values lambda)
|
||||
[(_ rev-defs [(define-values (var) (lambda (formals ...) proc-body)) . rest])
|
||||
#'(transform [(define-values (var) (lambda (formals ...) proc-body)) . rev-defs]
|
||||
rest)]
|
||||
[(_ rev-defs [body-expr])
|
||||
#`(begin
|
||||
#,@(map
|
||||
(lambda (def)
|
||||
(elim-call/cc-from-definition
|
||||
(normalize-definition def)))
|
||||
(reverse (syntax->list #'rev-defs)))
|
||||
(abort/cc #,(elim-call/cc (normalize-term #'body-expr))))]
|
||||
[(_ rev-defs [])
|
||||
(raise-syntax-error #f "module has no body expression" stx)]
|
||||
[_else
|
||||
(raise-syntax-error #f "extra body expression, or expression out of order" stx)])))
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
(module interaction mzscheme
|
||||
(require "expander.ss")
|
||||
(provide (all-from-except mzscheme #%module-begin)
|
||||
(rename lang-module-begin #%module-begin)
|
||||
start-interaction
|
||||
send/suspend))
|
||||
|
|
@ -8,22 +8,11 @@
|
|||
"lang/elim-callcc.ss"
|
||||
"lang/defun.ss")
|
||||
(require "abort-resume.ss"
|
||||
(only "persistent-web-interaction.ss"
|
||||
send/suspend/hidden
|
||||
send/suspend/url
|
||||
send/suspend/dispatch
|
||||
extract-proc/url embed-proc/url
|
||||
redirect/get
|
||||
start-servlet))
|
||||
"persistent-web-interaction.ss")
|
||||
(provide (rename lang-module-begin #%module-begin))
|
||||
(provide (all-from "abort-resume.ss")
|
||||
(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)
|
||||
(all-from "persistent-web-interaction.ss"))
|
||||
|
||||
(define-syntax lang-module-begin
|
||||
(make-lang-module-begin
|
||||
|
|
|
|||
|
|
@ -1,168 +0,0 @@
|
|||
(module normalizer mzscheme
|
||||
(require "syntax-utils.ss")
|
||||
(require-for-template mzscheme)
|
||||
(provide normalize-term
|
||||
normalize-definition)
|
||||
;; **************************************************
|
||||
;; SOURCE LANGUAGE
|
||||
;;
|
||||
;; program ::= definition* expr
|
||||
;;
|
||||
;; definition ::= (define-values (var ...) expr)
|
||||
;;
|
||||
;; expr ::= var
|
||||
;; | (lambda (var ...) expr ...)
|
||||
;; | (if expr expr)
|
||||
;; | (if expr expr expr)
|
||||
;; | (let-values () expr)
|
||||
;; | (let-values () expr ...)
|
||||
;; | (let-values ([(var)] expr) expr)
|
||||
;; | (let-values ([(var ...)] expr) expr)
|
||||
;; | (let-values ([(var ...)] expr) expr ...)
|
||||
;; | (#%app expr ...)
|
||||
;; | (#%datum . datum)
|
||||
;; | (#%top . var)
|
||||
;; | (begin expr ...)
|
||||
;; | (values expr ...)
|
||||
|
||||
;; **************************************************
|
||||
;; TARGET LANGUAGE
|
||||
;;
|
||||
;; program ::= definition* expr
|
||||
;;
|
||||
;; definition ::= (define-values (var ...) expr)
|
||||
;;
|
||||
;; expr ::= w | r | (#%app (lambda (var) expr) r)
|
||||
;;
|
||||
;; r ::= (if w expr)
|
||||
;; | (if w expr expr)
|
||||
;; | (#%app w w ...)
|
||||
;;
|
||||
;; w ::= var | (#%top . var) | value
|
||||
;; value ::= (#%datum . datum)
|
||||
;; | (lambda (var ...) expr)
|
||||
|
||||
;; **************************************************
|
||||
;; **************************************************
|
||||
|
||||
;; id: alpha -> alpha
|
||||
;; the identity function
|
||||
(define (id x) x)
|
||||
|
||||
;; normalize-definition: definition -> expr
|
||||
(define (normalize-definition def)
|
||||
(syntax-case def (define-values)
|
||||
[(define-values (ids ...) body-expr)
|
||||
(with-syntax ([body-expr (recertify #'body-expr def)])
|
||||
#`(define-values (ids ...) #,(normalize-term #'body-expr)))]
|
||||
[_else
|
||||
(raise-syntax-error #f "normalize-definition: dropped through" def)]))
|
||||
|
||||
;; normalize-term: source-expr -> target-expr
|
||||
;; transform a term into an application chain
|
||||
(define (normalize-term src-expr)
|
||||
(normalize id src-expr))
|
||||
|
||||
;; normalize: (w -> target-expr) source-expr -> target-expr
|
||||
;; normalize an expression given as a context and sub-expression
|
||||
(define (normalize ctxt expr)
|
||||
(syntax-case expr (lambda if let-values #%app #%datum #%top quote begin)
|
||||
[(lambda (formals ...) body)
|
||||
(with-syntax ([body (recertify #'body expr)])
|
||||
(ctxt #`(lambda (formals ...) #,(normalize-term #'body))))]
|
||||
[(lambda (formals ...) bodies ...)
|
||||
(normalize ctxt #'(lambda (formals ...) (begin bodies ...)))]
|
||||
[(lambda . anything)
|
||||
(raise-syntax-error #f "normalize: Not all lambda-expressions supported" expr)]
|
||||
[(if tst-expr csq-expr)
|
||||
(with-syntax ([(tst-expr csq-expr) (recertify* (list #'tst-expr #'csq-expr) expr)])
|
||||
(normalize
|
||||
(compose ctxt
|
||||
(lambda (val)
|
||||
#`(if #,val #,(normalize-term #'csq-expr))))
|
||||
#'tst-expr))]
|
||||
[(if tst-expr csq-expr alt-expr)
|
||||
(with-syntax ([(tst-expr csq-expr alt-expr) (recertify* (list #'tst-expr #'csq-expr #'alt-expr) expr)])
|
||||
(normalize
|
||||
(compose ctxt
|
||||
(lambda (val)
|
||||
#`(if #,val
|
||||
#,(normalize-term #'csq-expr)
|
||||
#,(normalize-term #'alt-expr))))
|
||||
#'tst-expr))]
|
||||
[(let-values () body)
|
||||
(normalize ctxt (recertify #'body expr))]
|
||||
[(let-values () body-expr rest-body-exprs ...)
|
||||
(with-syntax ([(body-expr rest-body-exprs ...)
|
||||
(recertify* (syntax->list #'(body-expr rest-body-exprs ...)) expr)])
|
||||
(normalize ctxt #'(let-values ([(throw-away) body-expr]) rest-body-exprs ...)))]
|
||||
[(let-values ([(var) rhs-expr]) body)
|
||||
(with-syntax ([(rhs-expr body) (recertify* (list #'rhs-expr #'body) expr)])
|
||||
(normalize ctxt #'(#%app (lambda (var) body) rhs-expr)))]
|
||||
[(let-values ([(vars ...) rhs-expr]) body)
|
||||
(with-syntax ([(rhs-expr body) (recertify* (list #'rhs-expr #'body) expr)])
|
||||
(normalize ctxt #'(#%app call-with-values
|
||||
(lambda () rhs-expr)
|
||||
(lambda (vars ...) body))))]
|
||||
[(let-values ([(vars ...) rhs-expr]) body-expr rest-body-exprs ...)
|
||||
(with-syntax ([(rhs-expr body-expr rest-body-exprs ...)
|
||||
(recertify* (syntax->list #'(rhs-expr body-expr rest-body-exprs ...)) expr)])
|
||||
(normalize ctxt #'(let-values ([(vars ...) rhs-expr])
|
||||
(let-values ([(throw-away) body-expr]) rest-body-exprs ...))))]
|
||||
[(#%app expr-rator expr-rands ...)
|
||||
(with-syntax ([(expr-rator expr-rands ...)
|
||||
(recertify* (syntax->list #'(expr-rator expr-rands ...)) expr)])
|
||||
(normalize
|
||||
(lambda (val0)
|
||||
(normalize*
|
||||
(compose ctxt
|
||||
(lambda (rest-vals)
|
||||
#`(#%app #,val0 #,@rest-vals)))
|
||||
(syntax->list #'(expr-rands ...))))
|
||||
#'expr-rator))]
|
||||
[(#%datum . datum) (ctxt expr)]
|
||||
[(#%top . var) (ctxt expr)]
|
||||
[(begin) (normalize ctxt #'(#%app (#%top . void)))]
|
||||
[(begin last-expr)
|
||||
(with-syntax ([last-expr (recertify #'last-expr expr)])
|
||||
(normalize ctxt #'last-expr))]
|
||||
[(begin first-expr rest-exprs ...)
|
||||
(with-syntax ([(first-expr rest-exprs ...)
|
||||
(recertify* (syntax->list #'(first-expr rest-exprs ...)) expr)])
|
||||
(normalize ctxt #'(let-values ([(throw-away) first-expr])
|
||||
(begin rest-exprs ...))))]
|
||||
[(quote datum) (ctxt expr)]
|
||||
[x (identifier? #'x)
|
||||
(ctxt expr)]
|
||||
[_else
|
||||
(raise-syntax-error #f "normalize: unsupported form" expr)]))
|
||||
|
||||
;; normalize*: ((listof w) -> target-expr) (listof source-expr) -> target-expr
|
||||
;; normalize an expression given as a context and list of sub-expressions
|
||||
(define (normalize* multi-ctxt exprs)
|
||||
(cond
|
||||
[(null? exprs) (multi-ctxt '())]
|
||||
[else
|
||||
(normalize
|
||||
(lambda (val)
|
||||
(normalize*
|
||||
(lambda (rest-vals)
|
||||
(multi-ctxt (cons val rest-vals)))
|
||||
(cdr exprs)))
|
||||
(car exprs))]))
|
||||
|
||||
;; 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)))))))
|
||||
|
|
@ -1,112 +0,0 @@
|
|||
(module persistent-expander mzscheme
|
||||
(require "abort-resume.ss")
|
||||
(require-for-syntax (lib "kerncase.ss" "syntax")
|
||||
(lib "list.ss")
|
||||
"labels.ss"
|
||||
"elim-letrec.ss"
|
||||
"normalizer.ss"
|
||||
"elim-call-cc.ss"
|
||||
"defunctionalize.ss")
|
||||
(provide lang-module-begin)
|
||||
(provide (all-from "abort-resume.ss"))
|
||||
|
||||
;; lang-module-begin
|
||||
;; Does the normal module-begin stuff, except it hands off all
|
||||
;; module forms to a collect macro.
|
||||
(define-syntax (lang-module-begin stx)
|
||||
(syntax-case stx ()
|
||||
[(_ form ...)
|
||||
#`(#%plain-module-begin
|
||||
;#,(datum->syntax-object stx '(require-for-syntax mzscheme))
|
||||
(collect () (form ...)))]))
|
||||
|
||||
;; collect
|
||||
;; (collect (def/expr ...) (module-form ...))
|
||||
;; collect expands each module-form until it can recognize what kind of form it is.
|
||||
;; If it's a define-syntaxes, require, require-for-syntax, or provide form,
|
||||
;; it lets it "pass through" the collect macro to be executed by the primitive module
|
||||
;; expander. If it's a define-values form, it expands the body and then reconstructs a
|
||||
;; define-values form to put in the def/exprs list. If it's any other kind of form, it
|
||||
;; fully expands the form and puts it on the def/exprs list.
|
||||
;;
|
||||
;; The fully expanded definitions and expressions are then passed (in the original
|
||||
;; order) to the transform macro.
|
||||
(define-syntax (collect stx)
|
||||
(define (module-identifier-member id ids)
|
||||
(cond [(null? ids) #f]
|
||||
[(module-identifier=? id (car ids)) ids]
|
||||
[else (module-identifier-member id (cdr ids))]))
|
||||
(syntax-case stx ()
|
||||
[(_ rev-def/exprs (form0 . forms))
|
||||
(let ([expand-context (syntax-local-context)]
|
||||
[stop-list (list*
|
||||
#'require
|
||||
#'require-for-syntax
|
||||
#'provide
|
||||
(kernel-form-identifier-list #'here))])
|
||||
(let ([e-form0 (local-expand #'form0 expand-context stop-list)])
|
||||
(syntax-case e-form0 (begin define-values)
|
||||
[(keyword . _)
|
||||
(and (identifier? #'keyword)
|
||||
(module-identifier-member #'keyword
|
||||
(list #'require #'require-for-syntax
|
||||
#'provide #'define-syntaxes)))
|
||||
#`(begin #,e-form0 (collect rev-def/exprs forms))]
|
||||
[(begin e-form ...)
|
||||
#`(collect rev-def/exprs (e-form ... . forms))]
|
||||
[(define-values (id ...) expr)
|
||||
(andmap identifier? (syntax->list #'(id ...)))
|
||||
(let ([e-expr (local-expand #'expr 'expression (list #'#%top))])
|
||||
#`(begin
|
||||
(collect [(define-values (id ...) #,e-expr) . rev-def/exprs]
|
||||
forms)))]
|
||||
[expr
|
||||
(let ([e-expr (local-expand #'expr 'expression (list #'#%top))])
|
||||
#`(collect [#,e-expr . rev-def/exprs] forms))])))]
|
||||
[(_ rev-def/exprs ())
|
||||
(with-syntax ([(def/expr ...) (reverse (syntax->list #'rev-def/exprs))])
|
||||
#'(transform () (def/expr ...)))]))
|
||||
|
||||
;; **********************************************************************
|
||||
;; **********************************************************************
|
||||
|
||||
; (define-for-syntax myprint printf)
|
||||
|
||||
;; transform
|
||||
;; This macro is where you put your transformations. Each def/expr is core mzscheme.
|
||||
;; Furthermore, no def/expr is a define-syntaxes, require etc form.
|
||||
(define-syntax (transform stx)
|
||||
(syntax-case stx (define-values lambda)
|
||||
[(_ rev-defs [(define-values (var) (lambda (formals ...) proc-body)) . rest])
|
||||
#'(transform [(define-values (var) (lambda (formals ...) proc-body)) . rev-defs]
|
||||
rest)]
|
||||
[(_ rev-defs [body-expr])
|
||||
(let* ([base-labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax-object->datum stx))))]
|
||||
[make-labeler (lambda (tag)
|
||||
(lambda ()
|
||||
(datum->syntax-object tag (base-labeling))))])
|
||||
(let ([new-defs (foldl
|
||||
(lambda (first rest)
|
||||
(append
|
||||
(defunctionalize-definition
|
||||
(elim-call/cc-from-definition
|
||||
(normalize-definition
|
||||
(elim-letrec-from-definition first)))
|
||||
(make-labeler first))
|
||||
rest))
|
||||
'()
|
||||
(syntax->list #'rev-defs))])
|
||||
(let-values ([(new-body-expr body-defs)
|
||||
(defunctionalize
|
||||
(elim-call/cc
|
||||
(normalize-term
|
||||
(elim-letrec #'body-expr)))
|
||||
(make-labeler #'body-expr))])
|
||||
#`(begin
|
||||
#,@new-defs
|
||||
#,@body-defs
|
||||
(abort/cc #,new-body-expr)))))]
|
||||
[(_ rev-defs [])
|
||||
(raise-syntax-error #f "module has no body expression" stx)]
|
||||
[_else
|
||||
(raise-syntax-error #f "extra body expression, or expression out of order" stx)])))
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
(module persistent-interaction mzscheme
|
||||
(require "persistent-expander.ss")
|
||||
(provide (all-from-except mzscheme #%module-begin)
|
||||
(rename lang-module-begin #%module-begin)
|
||||
start-interaction
|
||||
send/suspend))
|
||||
|
|
@ -1,15 +1,13 @@
|
|||
(module persistent-web-interaction mzscheme
|
||||
(require (rename "persistent-expander.ss" send/suspend0 send/suspend)
|
||||
(all-except "persistent-expander.ss" send/suspend)
|
||||
(require (rename "abort-resume.ss" send/suspend0 send/suspend)
|
||||
(all-except "abort-resume.ss" send/suspend)
|
||||
"session.ss"
|
||||
"stuff-url.ss"
|
||||
(lib "servlet-helpers.ss" "web-server" "private")
|
||||
(lib "serialize.ss")
|
||||
(lib "url.ss" "net"))
|
||||
|
||||
(provide (all-from-except mzscheme #%module-begin)
|
||||
(rename lang-module-begin #%module-begin)
|
||||
send/suspend/hidden
|
||||
(provide send/suspend/hidden
|
||||
send/suspend/url
|
||||
send/suspend/dispatch
|
||||
extract-proc/url embed-proc/url
|
||||
|
|
|
|||
|
|
@ -1,27 +0,0 @@
|
|||
(module syntax-utils mzscheme
|
||||
(require-for-template mzscheme)
|
||||
(provide recertify
|
||||
recertify*
|
||||
generate-formal)
|
||||
|
||||
;; syntax syntax -> syntax
|
||||
(define (recertify expr old-expr)
|
||||
(syntax-recertify expr old-expr (current-code-inspector) #f))
|
||||
|
||||
;; (listof syntax) syntax -> syntax
|
||||
;; recertify a list of syntax parts given the whole
|
||||
(define (recertify* exprs old-expr)
|
||||
(map (lambda (expr) (recertify expr old-expr))
|
||||
exprs))
|
||||
|
||||
;; generate-formal: -> identifier
|
||||
(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 '())
|
||||
#`(lambda (#,name) #,name))])
|
||||
(values #'formal #'ref-to-formal)))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -109,7 +109,7 @@
|
|||
"start-interaction called twice, dispatch-start will invoke different continuations"
|
||||
(let ([test-m02
|
||||
(make-module-eval
|
||||
(module m02 "../persistent-interaction.ss"
|
||||
(module m02 "../lang.ss"
|
||||
(define (id x) x)
|
||||
(+ (start-interaction id)
|
||||
(start-interaction id))))])
|
||||
|
|
|
|||
|
|
@ -1,73 +0,0 @@
|
|||
(module web-interaction mzscheme
|
||||
(require (rename "expander.ss" send/suspend0 send/suspend)
|
||||
(all-except "expander.ss" send/suspend)
|
||||
"utils.ss"
|
||||
"session.ss"
|
||||
(lib "list.ss")
|
||||
(lib "request-structs.ss" "web-server")
|
||||
(lib "url.ss" "net"))
|
||||
|
||||
(provide (all-from-except mzscheme #%module-begin)
|
||||
(rename lang-module-begin #%module-begin)
|
||||
send/suspend
|
||||
start-servlet)
|
||||
|
||||
;; start-servlet: -> request
|
||||
;; set the initial interaction point for the servlet
|
||||
(define (start-servlet)
|
||||
(start-session dispatch)
|
||||
(start-interaction
|
||||
(lambda (req)
|
||||
(or (url/id->continuation (request-uri req))
|
||||
(lambda (req) (dispatch-start req))))))
|
||||
|
||||
;; send/suspend: (url -> response) -> request
|
||||
;; the usual send/suspend
|
||||
(define (send/suspend page-maker)
|
||||
(send/suspend0
|
||||
(lambda (k)
|
||||
(page-maker (encode-k-id-in-url k)))))
|
||||
|
||||
;; **********************************************************************
|
||||
;; **********************************************************************
|
||||
;; CONTINUATION TABLES
|
||||
(define k-table (make-hash-table))
|
||||
|
||||
;; continuation->number: continuation -> number
|
||||
;; store a continuation and provide the key
|
||||
(define continuation->number
|
||||
(let ([n 0])
|
||||
(lambda (k)
|
||||
(set! n (add1 n))
|
||||
(printf "Adding ~a to ~S~n" n (hash-table-map k-table (lambda (k v) k)))
|
||||
(hash-table-put! k-table n k)
|
||||
(printf "Now: ~S~n" (hash-table-map k-table (lambda (k v) k)))
|
||||
n)))
|
||||
|
||||
;; url/id->continuation: url -> (union continuation #f)
|
||||
;; extract the key from the url and then lookup the continuation
|
||||
(define (url/id->continuation req-uri)
|
||||
(define ses-uri (session-url (current-session)))
|
||||
(define url-path-suffix (split-url-path ses-uri req-uri))
|
||||
(if ((length url-path-suffix) . >= . 1)
|
||||
(let ([k-id (string->number (first url-path-suffix))])
|
||||
(hash-table-get k-table k-id
|
||||
(lambda ()
|
||||
(printf "continuation ~a not found in ~S~n"
|
||||
k-id (hash-table-map k-table (lambda (k v) k)))
|
||||
#f)))
|
||||
#f))
|
||||
|
||||
;; encode-k-id-in-url: continuation -> url
|
||||
;; encode a continuation id in a url
|
||||
(define (encode-k-id-in-url k)
|
||||
(let ([uri (session-url (current-session))])
|
||||
(make-url
|
||||
(url-scheme uri)
|
||||
(url-user uri)
|
||||
(url-host uri)
|
||||
(url-port uri)
|
||||
#t
|
||||
(append (url-path uri) (list (make-path/param (number->string (continuation->number k)) empty)))
|
||||
(url-query uri)
|
||||
(url-fragment uri)))))
|
||||
Loading…
Reference in New Issue
Block a user