From ac170ef52eec5b6d2e298016d2b1b17f2c1cf517 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 25 May 2007 16:29:07 +0000 Subject: [PATCH] Removing old interaction languages and compilers svn: r6301 --- .../web-server/prototype-web-server/client.ss | 4 - .../prototype-web-server/defunctionalize.ss | 202 ------------------ .../prototype-web-server/elim-call-cc.ss | 116 ---------- .../prototype-web-server/elim-letrec.ss | 148 ------------- .../prototype-web-server/expander.ss | 88 -------- .../prototype-web-server/interaction.ss | 6 - .../web-server/prototype-web-server/lang.ss | 15 +- .../prototype-web-server/normalizer.ss | 168 --------------- .../persistent-expander.ss | 112 ---------- .../persistent-interaction.ss | 6 - .../persistent-web-interaction.ss | 8 +- .../prototype-web-server/syntax-utils.ss | 27 --- .../prototype-web-server/tests/lang-tests.ss | 2 +- .../prototype-web-server/web-interaction.ss | 73 ------- 14 files changed, 6 insertions(+), 969 deletions(-) delete mode 100644 collects/web-server/prototype-web-server/client.ss delete mode 100644 collects/web-server/prototype-web-server/defunctionalize.ss delete mode 100644 collects/web-server/prototype-web-server/elim-call-cc.ss delete mode 100644 collects/web-server/prototype-web-server/elim-letrec.ss delete mode 100644 collects/web-server/prototype-web-server/expander.ss delete mode 100644 collects/web-server/prototype-web-server/interaction.ss delete mode 100644 collects/web-server/prototype-web-server/normalizer.ss delete mode 100644 collects/web-server/prototype-web-server/persistent-expander.ss delete mode 100644 collects/web-server/prototype-web-server/persistent-interaction.ss delete mode 100644 collects/web-server/prototype-web-server/syntax-utils.ss delete mode 100644 collects/web-server/prototype-web-server/web-interaction.ss diff --git a/collects/web-server/prototype-web-server/client.ss b/collects/web-server/prototype-web-server/client.ss deleted file mode 100644 index 2dc0c6712d..0000000000 --- a/collects/web-server/prototype-web-server/client.ss +++ /dev/null @@ -1,4 +0,0 @@ -(module client mzscheme - (require "abort-resume.ss") - (provide dispatch-start - dispatch)) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/defunctionalize.ss b/collects/web-server/prototype-web-server/defunctionalize.ss deleted file mode 100644 index 1b9d3fcd7f..0000000000 --- a/collects/web-server/prototype-web-server/defunctionalize.ss +++ /dev/null @@ -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))])) - ) - diff --git a/collects/web-server/prototype-web-server/elim-call-cc.ss b/collects/web-server/prototype-web-server/elim-call-cc.ss deleted file mode 100644 index 4fff0877db..0000000000 --- a/collects/web-server/prototype-web-server/elim-call-cc.ss +++ /dev/null @@ -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]))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/elim-letrec.ss b/collects/web-server/prototype-web-server/elim-letrec.ss deleted file mode 100644 index 21e7818589..0000000000 --- a/collects/web-server/prototype-web-server/elim-letrec.ss +++ /dev/null @@ -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)) - ) - diff --git a/collects/web-server/prototype-web-server/expander.ss b/collects/web-server/prototype-web-server/expander.ss deleted file mode 100644 index 8c8a69674f..0000000000 --- a/collects/web-server/prototype-web-server/expander.ss +++ /dev/null @@ -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)]))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/interaction.ss b/collects/web-server/prototype-web-server/interaction.ss deleted file mode 100644 index 3421e308e9..0000000000 --- a/collects/web-server/prototype-web-server/interaction.ss +++ /dev/null @@ -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)) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/lang.ss b/collects/web-server/prototype-web-server/lang.ss index 4e4c0458fb..641583df72 100644 --- a/collects/web-server/prototype-web-server/lang.ss +++ b/collects/web-server/prototype-web-server/lang.ss @@ -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 diff --git a/collects/web-server/prototype-web-server/normalizer.ss b/collects/web-server/prototype-web-server/normalizer.ss deleted file mode 100644 index 142006c10f..0000000000 --- a/collects/web-server/prototype-web-server/normalizer.ss +++ /dev/null @@ -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))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/persistent-expander.ss b/collects/web-server/prototype-web-server/persistent-expander.ss deleted file mode 100644 index ce245cdc8a..0000000000 --- a/collects/web-server/prototype-web-server/persistent-expander.ss +++ /dev/null @@ -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)]))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/persistent-interaction.ss b/collects/web-server/prototype-web-server/persistent-interaction.ss deleted file mode 100644 index caf3dc39ae..0000000000 --- a/collects/web-server/prototype-web-server/persistent-interaction.ss +++ /dev/null @@ -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)) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/persistent-web-interaction.ss b/collects/web-server/prototype-web-server/persistent-web-interaction.ss index b9cf5f8a9d..e5247b0d48 100644 --- a/collects/web-server/prototype-web-server/persistent-web-interaction.ss +++ b/collects/web-server/prototype-web-server/persistent-web-interaction.ss @@ -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 diff --git a/collects/web-server/prototype-web-server/syntax-utils.ss b/collects/web-server/prototype-web-server/syntax-utils.ss deleted file mode 100644 index 1e0e7fd0ec..0000000000 --- a/collects/web-server/prototype-web-server/syntax-utils.ss +++ /dev/null @@ -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))))) - - - \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/tests/lang-tests.ss b/collects/web-server/prototype-web-server/tests/lang-tests.ss index 201eed1f29..d1ceec0c03 100644 --- a/collects/web-server/prototype-web-server/tests/lang-tests.ss +++ b/collects/web-server/prototype-web-server/tests/lang-tests.ss @@ -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))))]) diff --git a/collects/web-server/prototype-web-server/web-interaction.ss b/collects/web-server/prototype-web-server/web-interaction.ss deleted file mode 100644 index 1dbab43d33..0000000000 --- a/collects/web-server/prototype-web-server/web-interaction.ss +++ /dev/null @@ -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))))) \ No newline at end of file