From a4023f2ebe5aa41a145546ab5ce4a5099f99afef Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 21 Nov 2007 16:51:53 +0000 Subject: [PATCH] v4 progress svn: r7802 --- .../dispatchers/dispatch-passwords.ss | 26 +- collects/web-server/lang.ss | 46 +- collects/web-server/lang/abort-resume.ss | 324 +- collects/web-server/lang/anormal.ss | 357 +- collects/web-server/lang/defun.ss | 299 +- collects/web-server/lang/elim-callcc.ss | 342 +- collects/web-server/lang/elim-letrec.ss | 258 +- collects/web-server/lang/freevars.ss | 283 +- collects/web-server/lang/lang-api.ss | 46 +- collects/web-server/lang/util.ss | 416 ++- collects/web-server/lang/web-param.ss | 112 +- collects/web-server/private/closure.ss | 252 +- collects/web-server/private/mod-map.ss | 8 +- .../tests/dispatchers/dispatch-lang-test.ss | 6 +- .../dispatchers/dispatch-servlets-test.ss | 8 +- collects/web-server/tests/util.ss | 7 +- collects/web-server/tmp/htmlprag/doc.txt | 422 +++ .../web-server/tmp/htmlprag/doc/index.html | 458 +++ collects/web-server/tmp/htmlprag/doc/keywords | 27 + collects/web-server/tmp/htmlprag/htmlprag.scm | 2382 +++++++++++++ collects/web-server/tmp/htmlprag/htmlprag.ss | 2383 +++++++++++++ collects/web-server/tmp/htmlprag/info.ss | 12 + .../web-server/tmp/ssax/SXML-tree-trans.ss | 265 ++ collects/web-server/tmp/ssax/access-remote.ss | 314 ++ collects/web-server/tmp/ssax/char-encoding.ss | 66 + collects/web-server/tmp/ssax/common.ss | 49 + collects/web-server/tmp/ssax/doc.txt | 114 + collects/web-server/tmp/ssax/http.ss | 327 ++ collects/web-server/tmp/ssax/id.ss | 562 ++++ collects/web-server/tmp/ssax/info.ss | 10 + collects/web-server/tmp/ssax/input-parse.ss | 482 +++ collects/web-server/tmp/ssax/look-for-str.ss | 107 + collects/web-server/tmp/ssax/mime.ss | 165 + collects/web-server/tmp/ssax/multi-parser.ss | 458 +++ collects/web-server/tmp/ssax/myenv.ss | 380 +++ collects/web-server/tmp/ssax/parse-error.ss | 48 + collects/web-server/tmp/ssax/srfi-12.ss | 323 ++ collects/web-server/tmp/ssax/ssax-code.ss | 61 + collects/web-server/tmp/ssax/ssax-prim.ss | 71 + collects/web-server/tmp/ssax/ssax.ss | 37 + collects/web-server/tmp/ssax/sxpathlib.ss | 538 +++ collects/web-server/tmp/ssax/util.ss | 293 ++ collects/web-server/tmp/ssax/xlink-parser.ss | 1282 +++++++ collects/web-server/tmp/sxml/ddo-axes.ss | 2159 ++++++++++++ collects/web-server/tmp/sxml/ddo-txpath.ss | 2222 ++++++++++++ collects/web-server/tmp/sxml/doc.txt | 376 +++ collects/web-server/tmp/sxml/guides.ss | 166 + collects/web-server/tmp/sxml/info.ss | 10 + collects/web-server/tmp/sxml/lazy-ssax.ss | 217 ++ collects/web-server/tmp/sxml/lazy-xpath.ss | 2325 +++++++++++++ collects/web-server/tmp/sxml/libmisc.ss | 348 ++ collects/web-server/tmp/sxml/modif.ss | 852 +++++ collects/web-server/tmp/sxml/serializer.ss | 1527 +++++++++ collects/web-server/tmp/sxml/stx-engine.ss | 662 ++++ collects/web-server/tmp/sxml/sxml-tools.ss | 871 +++++ collects/web-server/tmp/sxml/sxml.ss | 35 + collects/web-server/tmp/sxml/sxpath-ext.ss | 626 ++++ collects/web-server/tmp/sxml/sxpath.ss | 226 ++ collects/web-server/tmp/sxml/sxpathlib.ss | 536 +++ collects/web-server/tmp/sxml/txpath.ss | 1115 ++++++ collects/web-server/tmp/sxml/xpath-ast.ss | 469 +++ .../tmp/sxml/xpath-context_xlink.ss | 2983 +++++++++++++++++ collects/web-server/tmp/sxml/xpath-parser.ss | 1553 +++++++++ 63 files changed, 32295 insertions(+), 1409 deletions(-) create mode 100644 collects/web-server/tmp/htmlprag/doc.txt create mode 100644 collects/web-server/tmp/htmlprag/doc/index.html create mode 100644 collects/web-server/tmp/htmlprag/doc/keywords create mode 100644 collects/web-server/tmp/htmlprag/htmlprag.scm create mode 100644 collects/web-server/tmp/htmlprag/htmlprag.ss create mode 100644 collects/web-server/tmp/htmlprag/info.ss create mode 100644 collects/web-server/tmp/ssax/SXML-tree-trans.ss create mode 100644 collects/web-server/tmp/ssax/access-remote.ss create mode 100644 collects/web-server/tmp/ssax/char-encoding.ss create mode 100644 collects/web-server/tmp/ssax/common.ss create mode 100644 collects/web-server/tmp/ssax/doc.txt create mode 100644 collects/web-server/tmp/ssax/http.ss create mode 100644 collects/web-server/tmp/ssax/id.ss create mode 100644 collects/web-server/tmp/ssax/info.ss create mode 100644 collects/web-server/tmp/ssax/input-parse.ss create mode 100644 collects/web-server/tmp/ssax/look-for-str.ss create mode 100644 collects/web-server/tmp/ssax/mime.ss create mode 100644 collects/web-server/tmp/ssax/multi-parser.ss create mode 100644 collects/web-server/tmp/ssax/myenv.ss create mode 100644 collects/web-server/tmp/ssax/parse-error.ss create mode 100644 collects/web-server/tmp/ssax/srfi-12.ss create mode 100644 collects/web-server/tmp/ssax/ssax-code.ss create mode 100644 collects/web-server/tmp/ssax/ssax-prim.ss create mode 100644 collects/web-server/tmp/ssax/ssax.ss create mode 100644 collects/web-server/tmp/ssax/sxpathlib.ss create mode 100644 collects/web-server/tmp/ssax/util.ss create mode 100644 collects/web-server/tmp/ssax/xlink-parser.ss create mode 100644 collects/web-server/tmp/sxml/ddo-axes.ss create mode 100644 collects/web-server/tmp/sxml/ddo-txpath.ss create mode 100644 collects/web-server/tmp/sxml/doc.txt create mode 100644 collects/web-server/tmp/sxml/guides.ss create mode 100644 collects/web-server/tmp/sxml/info.ss create mode 100644 collects/web-server/tmp/sxml/lazy-ssax.ss create mode 100644 collects/web-server/tmp/sxml/lazy-xpath.ss create mode 100644 collects/web-server/tmp/sxml/libmisc.ss create mode 100644 collects/web-server/tmp/sxml/modif.ss create mode 100644 collects/web-server/tmp/sxml/serializer.ss create mode 100644 collects/web-server/tmp/sxml/stx-engine.ss create mode 100644 collects/web-server/tmp/sxml/sxml-tools.ss create mode 100644 collects/web-server/tmp/sxml/sxml.ss create mode 100644 collects/web-server/tmp/sxml/sxpath-ext.ss create mode 100644 collects/web-server/tmp/sxml/sxpath.ss create mode 100644 collects/web-server/tmp/sxml/sxpathlib.ss create mode 100644 collects/web-server/tmp/sxml/txpath.ss create mode 100644 collects/web-server/tmp/sxml/xpath-ast.ss create mode 100644 collects/web-server/tmp/sxml/xpath-context_xlink.ss create mode 100644 collects/web-server/tmp/sxml/xpath-parser.ss diff --git a/collects/web-server/dispatchers/dispatch-passwords.ss b/collects/web-server/dispatchers/dispatch-passwords.ss index ffc0e67d1b..fdfaea3ad0 100644 --- a/collects/web-server/dispatchers/dispatch-passwords.ss +++ b/collects/web-server/dispatchers/dispatch-passwords.ss @@ -1,5 +1,6 @@ (module dispatch-passwords mzscheme (require (lib "kw.ss") + (lib "list.ss") (lib "url.ss" "net") (lib "contract.ss")) (require "dispatch.ss" @@ -22,12 +23,12 @@ (define password-cache (box #f)) (define (update-password-cache!) (when (and (file-exists? password-file) (memq 'read (file-or-directory-permissions password-file))) - (let ([cur-mtime (file-or-directory-modify-seconds password-file)]) - (when (or (not (unbox last-read-time)) - (cur-mtime . > . (unbox last-read-time)) - (not (unbox password-cache))) - (set-box! last-read-time cur-mtime) - (set-box! password-cache (read-passwords password-file)))))) + (let ([cur-mtime (file-or-directory-modify-seconds password-file)]) + (when (or (not (unbox last-read-time)) + (cur-mtime . > . (unbox last-read-time)) + (not (unbox password-cache))) + (set-box! last-read-time cur-mtime) + (set-box! password-cache (read-passwords password-file)))))) (define (read-password-cache) (update-password-cache!) (unbox password-cache)) @@ -77,11 +78,14 @@ (format "could not load password file ~a" password-path) (current-continuation-marks))))]) (let ([passwords - (let ([raw (load password-path)]) - (unless (password-list? raw) - (raise "malformed passwords")) - (map (lambda (x) (make-pass-entry (car x) (regexp (cadr x)) (cddr x))) - raw))]) + (with-input-from-file + password-path + (lambda () + (let ([raw (second (read))]) + (unless (password-list? raw) + (raise "malformed passwords")) + (map (lambda (x) (make-pass-entry (car x) (regexp (cadr x)) (cddr x))) + raw))))]) ;; string symbol bytes -> (or/c #f string) (lambda (request-path user-name password) diff --git a/collects/web-server/lang.ss b/collects/web-server/lang.ss index dee06d5f7c..0ee8a32389 100644 --- a/collects/web-server/lang.ss +++ b/collects/web-server/lang.ss @@ -1,22 +1,24 @@ -(module lang mzscheme - (require-for-syntax (lib "etc.ss") - (lib "list.ss") - "lang/labels.ss" - "lang/util.ss" - "lang/elim-letrec.ss" - "lang/anormal.ss" - "lang/elim-callcc.ss" - "lang/defun.ss") - (require "lang/lang-api.ss") - (provide (rename lang-module-begin #%module-begin)) - (provide (all-from "lang/lang-api.ss")) - - (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))))))) \ No newline at end of file +#lang scheme/base +(require (for-syntax scheme/base) + (for-syntax (lib "etc.ss")) + (for-syntax (lib "list.ss")) + (for-syntax "lang/labels.ss") + (for-syntax "lang/util.ss") + (for-syntax "lang/elim-letrec.ss") + (for-syntax "lang/anormal.ss") + (for-syntax "lang/elim-callcc.ss") + (for-syntax "lang/defun.ss") + "lang/lang-api.ss") + +(provide (rename-out [lang-module-begin #%plain-module-begin]) + (all-from-out "lang/lang-api.ss")) + +(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)))))) \ No newline at end of file diff --git a/collects/web-server/lang/abort-resume.ss b/collects/web-server/lang/abort-resume.ss index b5c8a7bb02..4bf3d8ff37 100644 --- a/collects/web-server/lang/abort-resume.ss +++ b/collects/web-server/lang/abort-resume.ss @@ -1,164 +1,164 @@ -(module abort-resume mzscheme - (require (lib "list.ss") - (lib "plt-match.ss") - (lib "serialize.ss") - "../private/define-closure.ss" - "../lang/web-cells.ss") - (provide - - ;; AUXILLIARIES - abort - resume - the-cont-key - the-save-cm-key - safe-call? - the-undef - activation-record-list - current-saved-continuation-marks-and - - ;; "SERVLET" INTERFACE - send/suspend - - ;; "CLIENT" INTERFACE - dispatch-start - dispatch) - - ;; ********************************************************************** - ;; ********************************************************************** - ;; AUXILLIARIES - (define-struct mark-key ()) - (define the-cont-key (make-mark-key)) - (define the-save-cm-key (make-mark-key)) - (define safe-call? (make-mark-key)) - (define web-prompt (make-continuation-prompt-tag 'web)) - - (define (current-saved-continuation-marks-and key val) - (reverse - (list* (cons key val) - (let-values ([(current) - (continuation-mark-set->list (current-continuation-marks) the-save-cm-key)]) - (if (empty? current) - empty - (first current)))))) - - ;; current-continuation-as-list: -> (listof value) - ;; check the safety marks and return the list of marks representing the continuation - (define (activation-record-list) - (let* ([cm (current-continuation-marks)] - [sl (reverse (continuation-mark-set->list cm safe-call?))]) - (if (andmap (lambda (x) - (if (pair? x) - (car x) - x)) - sl) - (begin #;(printf "Safe continuation capture from ~S with cm ~S~n" sl cm) - #;(printf "CMs: ~S~n" (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key))) - (reverse (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key)))) - (error "Attempt to capture a continuation from within an unsafe context:" sl)))) - - ;; abort: ( -> alpha) -> alpha - ;; erase the stack and apply a thunk - (define (abort thunk) - #;(printf "abort ~S~n" thunk) - (abort-current-continuation web-prompt thunk)) - - ;; resume: (listof (value -> value)) value -> value - ;; resume a computation given a value and list of frame procedures - (define (resume frames val) - #;(printf "~S~n" `(resume ,frames ,val)) - (match frames - [(list) - (apply values val)] - [(list-rest f fs) - (match f - [(vector #f #f) - (error 'resume "Empty frame")] - [(vector f #f) - (call-with-values (lambda () (with-continuation-mark the-cont-key f (resume fs val))) - f)] - [(vector #f (list)) - (resume fs val)] - [(vector #f (list-rest (list-rest cm-key cm-val) cms)) - (with-continuation-mark - the-save-cm-key - (current-saved-continuation-marks-and cm-key cm-val) - (with-continuation-mark cm-key cm-val - (begin - #;(printf "r: w-c-m ~S ~S~n" cm-key cm-val) - (resume (list* (vector #f cms) fs) val))))] - [(vector f cm) - (resume (list* (vector f #f) (vector #f cm) fs) val)])])) - - ;; rebuild-cms : frames (-> value) -> value - (define (rebuild-cms frames thunk) - #;(printf "~S~n" `(rebuild-cms ,frames ,thunk)) - (match frames - [(list) - (thunk)] - [(list-rest f fs) - (match f - [(vector f #f) - (rebuild-cms fs thunk)] - [(vector f (list)) - (rebuild-cms fs thunk)] - [(vector f (list-rest (list-rest cm-key cm-val) cms)) +#lang scheme/base +(require (lib "list.ss") + (lib "plt-match.ss") + (lib "serialize.ss") + "../private/define-closure.ss" + "../lang/web-cells.ss") +(provide + + ;; AUXILLIARIES + abort + resume + the-cont-key + the-save-cm-key + safe-call? + the-undef + activation-record-list + current-saved-continuation-marks-and + + ;; "SERVLET" INTERFACE + send/suspend + + ;; "CLIENT" INTERFACE + dispatch-start + dispatch) + +;; ********************************************************************** +;; ********************************************************************** +;; AUXILLIARIES +(define-struct mark-key ()) +(define the-cont-key (make-mark-key)) +(define the-save-cm-key (make-mark-key)) +(define safe-call? (make-mark-key)) +(define web-prompt (make-continuation-prompt-tag 'web)) + +(define (current-saved-continuation-marks-and key val) + (reverse + (list* (cons key val) + (let-values ([(current) + (continuation-mark-set->list (current-continuation-marks) the-save-cm-key)]) + (if (empty? current) + empty + (first current)))))) + +;; current-continuation-as-list: -> (listof value) +;; check the safety marks and return the list of marks representing the continuation +(define (activation-record-list) + (let* ([cm (current-continuation-marks)] + [sl (reverse (continuation-mark-set->list cm safe-call?))]) + (if (andmap (lambda (x) + (if (pair? x) + (car x) + x)) + sl) + (begin #;(printf "Safe continuation capture from ~S with cm ~S~n" sl cm) + #;(printf "CMs: ~S~n" (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key))) + (reverse (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key)))) + (error "Attempt to capture a continuation from within an unsafe context:" sl)))) + +;; abort: ( -> alpha) -> alpha +;; erase the stack and apply a thunk +(define (abort thunk) + #;(printf "abort ~S~n" thunk) + (abort-current-continuation web-prompt thunk)) + +;; resume: (listof (value -> value)) value -> value +;; resume a computation given a value and list of frame procedures +(define (resume frames val) + #;(printf "~S~n" `(resume ,frames ,val)) + (match frames + [(list) + (apply values val)] + [(list-rest f fs) + (match f + [(vector #f #f) + (error 'resume "Empty frame")] + [(vector f #f) + (call-with-values (lambda () (with-continuation-mark the-cont-key f (resume fs val))) + f)] + [(vector #f (list)) + (resume fs val)] + [(vector #f (list-rest (list-rest cm-key cm-val) cms)) + (with-continuation-mark + the-save-cm-key + (current-saved-continuation-marks-and cm-key cm-val) (with-continuation-mark cm-key cm-val (begin - #;(printf "rcm: w-c-m ~S ~S~n" cm-key cm-val) - (rebuild-cms (list* (vector #f cms) fs) thunk)))])])) - - (define (abort/cc thunk) - (call-with-continuation-prompt - thunk - web-prompt)) - - ;; a serializable undefined value - (define-serializable-struct undef ()) - (define the-undef (make-undef)) - - ;; ********************************************************************** - ;; ********************************************************************** - ;; "SERVLET" INTERFACE - - (define-closure kont x (wcs current-marks) - (abort (lambda () - ; Restoring the web-cells is separate from the continuation - (restore-web-cell-set! wcs) - (resume current-marks x)))) - - ;; send/suspend: (continuation -> response) -> request - ;; produce the current response and wait for the next request - (define (send/suspend response-maker) - (with-continuation-mark safe-call? '(#t send/suspend) - (let ([current-marks (activation-record-list)] - [wcs (capture-web-cell-set)]) - ((lambda (k) - (abort (lambda () - ; Since we escaped from the previous context, we need to re-install the user's continuation-marks - (rebuild-cms current-marks (lambda () (response-maker k)))))) - (make-kont (lambda () (values wcs current-marks))))))) - - ;; ********************************************************************** - ;; ********************************************************************** - ;; "CLIENT" INTERFACE - - ;; dispatch-start: (request -> response) request -> reponse - ;; pass the initial request to the starting interaction point - (define (dispatch-start start req0) - (abort/cc - (lambda () - (with-continuation-mark safe-call? '(#t start) - (start - (with-continuation-mark the-cont-key start - req0)))))) - - ;; dispatch: (request -> (request -> response)) request -> response - ;; lookup the continuation for this request and invoke it - (define (dispatch decode-continuation req) - (abort/cc - (lambda () - (cond - [(decode-continuation req) - => (lambda (k) (k req))] - [else - (error "no continuation associated with the provided request")]))))) \ No newline at end of file + #;(printf "r: w-c-m ~S ~S~n" cm-key cm-val) + (resume (list* (vector #f cms) fs) val))))] + [(vector f cm) + (resume (list* (vector f #f) (vector #f cm) fs) val)])])) + +;; rebuild-cms : frames (-> value) -> value +(define (rebuild-cms frames thunk) + #;(printf "~S~n" `(rebuild-cms ,frames ,thunk)) + (match frames + [(list) + (thunk)] + [(list-rest f fs) + (match f + [(vector f #f) + (rebuild-cms fs thunk)] + [(vector f (list)) + (rebuild-cms fs thunk)] + [(vector f (list-rest (list-rest cm-key cm-val) cms)) + (with-continuation-mark cm-key cm-val + (begin + #;(printf "rcm: w-c-m ~S ~S~n" cm-key cm-val) + (rebuild-cms (list* (vector #f cms) fs) thunk)))])])) + +(define (abort/cc thunk) + (call-with-continuation-prompt + thunk + web-prompt)) + +;; a serializable undefined value +(define-serializable-struct undef ()) +(define the-undef (make-undef)) + +;; ********************************************************************** +;; ********************************************************************** +;; "SERVLET" INTERFACE + +(define-closure kont x (wcs current-marks) + (abort (lambda () + ; Restoring the web-cells is separate from the continuation + (restore-web-cell-set! wcs) + (resume current-marks x)))) + +;; send/suspend: (continuation -> response) -> request +;; produce the current response and wait for the next request +(define (send/suspend response-maker) + (with-continuation-mark safe-call? '(#t send/suspend) + (let ([current-marks (activation-record-list)] + [wcs (capture-web-cell-set)]) + ((lambda (k) + (abort (lambda () + ; Since we escaped from the previous context, we need to re-install the user's continuation-marks + (rebuild-cms current-marks (lambda () (response-maker k)))))) + (make-kont (lambda () (values wcs current-marks))))))) + +;; ********************************************************************** +;; ********************************************************************** +;; "CLIENT" INTERFACE + +;; dispatch-start: (request -> response) request -> reponse +;; pass the initial request to the starting interaction point +(define (dispatch-start start req0) + (abort/cc + (lambda () + (with-continuation-mark safe-call? '(#t start) + (start + (with-continuation-mark the-cont-key start + req0)))))) + +;; dispatch: (request -> (request -> response)) request -> response +;; lookup the continuation for this request and invoke it +(define (dispatch decode-continuation req) + (abort/cc + (lambda () + (cond + [(decode-continuation req) + => (lambda (k) (k req))] + [else + (error "no continuation associated with the provided request")])))) \ No newline at end of file diff --git a/collects/web-server/lang/anormal.ss b/collects/web-server/lang/anormal.ss index e538786538..6f97a7b25a 100644 --- a/collects/web-server/lang/anormal.ss +++ b/collects/web-server/lang/anormal.ss @@ -1,183 +1,180 @@ -(module anormal mzscheme - (require-for-template mzscheme) - (require (lib "kerncase.ss" "syntax") - (lib "list.ss") - (lib "plt-match.ss") - "util.ss") - (provide make-anormal-term) +#lang scheme/base +(require (lib "kerncase.ss" "syntax") + (lib "list.ss") + (lib "plt-match.ss") + "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)]) + #`(#%plain-app (#%plain-lambda (#,x) #,(ctxt ref-to-x)) #,(frame val)))))) + +(define (make-anormal-term elim-letrec-term) + (define (anormal-term stx) + (anormal id stx)) - ; 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) - (recertify - stx - (kernel-syntax-case - stx (transformer?) - [(begin) - (anormal ctxt (syntax/loc stx (#%app (#%top . void))))] - [(begin lbe) - (anormal ctxt (syntax/loc stx lbe))] - [(begin fbe be ...) + (define (anormal ctxt stx) + (recertify + stx + (kernel-syntax-case + stx (transformer?) + [(begin) + (anormal ctxt (syntax/loc stx (#%plain-app (#%top . void))))] + [(begin lbe) + (anormal ctxt (syntax/loc stx lbe))] + [(begin fbe be ...) + (anormal ctxt + (syntax/loc stx + (#%plain-app call-with-values + (#%plain-lambda () fbe) + (#%plain-lambda throw-away + (begin be ...)))))] + [(begin0) + (anormal ctxt (syntax/loc stx (#%plain-app (#%top . void))))] + [(begin0 lbe) + (anormal ctxt (syntax/loc stx lbe))] + [(begin0 fbe be ...) + (let-values ([(save ref-to-save) (generate-formal 'save)]) (anormal ctxt - (syntax/loc stx - (#%app call-with-values - (lambda () fbe) - (lambda throw-away - (begin be ...)))))] - [(begin0) - (anormal ctxt (syntax/loc stx (#%app (#%top . void))))] - [(begin0 lbe) - (anormal ctxt (syntax/loc stx lbe))] - [(begin0 fbe be ...) - (let-values ([(save ref-to-save) (generate-formal 'save)]) - (anormal ctxt - (quasisyntax/loc stx - (#%app call-with-values - (lambda () fbe) - (lambda #,save - (begin be ... - (#%app apply values #,ref-to-save)))))))] - [(define-values (v ...) ve) - (with-syntax ([ve (anormal-term #'ve)]) - (syntax/loc stx - (define-values (v ...) ve)))] - [(define-syntaxes (v ...) ve) - stx] - [(define-values-for-syntax (v ...) ve) - stx] - [(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 + (quasisyntax/loc stx + (#%plain-app call-with-values + (#%plain-lambda () fbe) + (#%plain-lambda #,save + (begin be ... + (#%plain-app apply values #,ref-to-save)))))))] + [(define-values (v ...) ve) + (with-syntax ([ve (anormal-term #'ve)]) + (syntax/loc stx + (define-values (v ...) ve)))] + [(define-syntaxes (v ...) ve) + stx] + [(define-values-for-syntax (v ...) ve) + stx] + [(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 + (#%plain-app (#%plain-lambda (v) be) + ve)))] + [(let-values ([(v ...) ve]) be) + (anormal ctxt + (syntax/loc stx + (#%plain-app call-with-values + (#%plain-lambda () ve) + (#%plain-lambda (v ...) be))))] + [(let-values ([(fv ...) fve] [(v ...) ve] ...) be) + (anormal ctxt + (syntax/loc stx + (let-values ([(fv ...) fve]) (let-values ([(v ...) ve] ...) - (begin be ...))))] - [(letrec-values ([(v ...) ve] ...) be ...) - (anormal ctxt - (elim-letrec-term stx))] - [(#%plain-lambda formals be ...) - (with-syntax ([nbe (anormal-term (syntax/loc stx (begin be ...)))]) - (ctxt (syntax/loc stx (#%plain-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 ...) - (anormal ctxt - (elim-letrec-term 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) - (anormal - (compose ctxt - (lambda (d) - (quasisyntax/loc stx (#%expression #,d)))) - #'d)] - [(#%plain-app fe e ...) - (anormal - (lambda (val0) - (anormal* - (compose ctxt - (lambda (rest-vals) - (quasisyntax/loc stx - (#%plain-app #,val0 #,@rest-vals)))) - (syntax->list #'(e ...)))) - #'fe)] - [(#%top . v) - (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)) \ No newline at end of file + 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))] + [(#%plain-lambda formals be ...) + (with-syntax ([nbe (anormal-term (syntax/loc stx (begin be ...)))]) + (ctxt (syntax/loc stx (#%plain-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)] + [(quote datum) + (ctxt stx)] + [(quote-syntax datum) + (ctxt stx)] + [(letrec-syntaxes+values ([(sv ...) se] ...) + ([(vv ...) ve] ...) + be ...) + (anormal ctxt + (elim-letrec-term 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) + (anormal + (compose ctxt + (lambda (d) + (quasisyntax/loc stx (#%expression #,d)))) + #'d)] + [(#%plain-app fe e ...) + (anormal + (lambda (val0) + (anormal* + (compose ctxt + (lambda (rest-vals) + (quasisyntax/loc stx + (#%plain-app #,val0 #,@rest-vals)))) + (syntax->list #'(e ...)))) + #'fe)] + [(#%top . v) + (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) \ No newline at end of file diff --git a/collects/web-server/lang/defun.ss b/collects/web-server/lang/defun.ss index 307e75cd5a..7b00335ca3 100644 --- a/collects/web-server/lang/defun.ss +++ b/collects/web-server/lang/defun.ss @@ -1,151 +1,148 @@ -(module defun mzscheme - (require-for-template mzscheme) - (require (lib "kerncase.ss" "syntax") - (lib "list.ss") - (lib "plt-match.ss") - "util.ss" - "freevars.ss" - "../private/closure.ss") - (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) - (recertify/new-defs - stx - (lambda () - (kernel-syntax-case - stx (transformer?) - [(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) - (values stx - empty)] - [(define-values-for-syntax (v ...) ve) - (values stx - empty)] - [(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))))] - [(#%plain-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 (#%plain-lambda formals nbe ...)))]) - (values (if (empty? fvars) - (quasisyntax/loc stx (#,make-CLOSURE)) - (quasisyntax/loc stx (#,make-CLOSURE (#%plain-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) - (let-values ([(nd d-defs) (defun #'d)]) - (values (quasisyntax/loc stx (#%expression #,nd)) - d-defs))] - [(#%plain-app e ...) - (let-values ([(es defs) (defun* (syntax->list #'(e ...)))]) - (values (quasisyntax/loc stx (#%plain-app #,@es)) - defs))] - [(#%top . v) - (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)))))) \ No newline at end of file +#lang scheme/base +(require (lib "kerncase.ss" "syntax") + (lib "list.ss") + (lib "plt-match.ss") + "util.ss" + "freevars.ss" + "../private/closure.ss") +(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) + (recertify/new-defs + stx + (lambda () + (kernel-syntax-case + stx (transformer?) + [(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) + (values stx + empty)] + [(define-values-for-syntax (v ...) ve) + (values stx + empty)] + [(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))))] + [(#%plain-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 (#%plain-lambda formals nbe ...)))]) + (values (if (empty? fvars) + (quasisyntax/loc stx (#,make-CLOSURE)) + (quasisyntax/loc stx (#,make-CLOSURE (#%plain-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))] + [(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) + (let-values ([(nd d-defs) (defun #'d)]) + (values (quasisyntax/loc stx (#%expression #,nd)) + d-defs))] + [(#%plain-app e ...) + (let-values ([(es defs) (defun* (syntax->list #'(e ...)))]) + (values (quasisyntax/loc stx (#%plain-app #,@es)) + defs))] + [(#%top . v) + (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))))) \ No newline at end of file diff --git a/collects/web-server/lang/elim-callcc.ss b/collects/web-server/lang/elim-callcc.ss index 928e462c3c..2b542016d4 100644 --- a/collects/web-server/lang/elim-callcc.ss +++ b/collects/web-server/lang/elim-callcc.ss @@ -1,174 +1,170 @@ -(module elim-callcc mzscheme - (require-for-template mzscheme - "../lang/abort-resume.ss") - (require-for-syntax "../lang/abort-resume.ss") - (require (lib "kerncase.ss" "syntax") - "util.ss") - (provide elim-callcc) - - (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) - (recertify - 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) - (recertify - stx - (kernel-syntax-case* - stx (transformer?) (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) - stx] - [(define-values-for-syntax (v ...) ve) - stx] - [(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)] - [(#%plain-lambda formals be) - (with-syntax ([be (elim-callcc #'be)]) - (syntax/loc stx - (#%plain-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)]) - ; XXX Could be dangerous to evaluate ke-prime and me-prime twice - (markit - (quasisyntax/loc stx - (with-continuation-mark #,ke-prime #,me-prime - (with-continuation-mark - the-save-cm-key - (#%plain-app current-saved-continuation-marks-and #,ke-prime #,me-prime) - #,be-prime)))))] - [(#%expression d) - (markit (quasisyntax/loc stx (#%expression #,(elim-callcc #'d))))] - [(#%plain-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 - (#%plain-app #,(elim-callcc #'w) - (#%plain-app (#%plain-lambda (#,cm) - (#%plain-lambda #,x - (#%plain-app abort - (#%plain-lambda () (#%plain-app resume #,ref-to-cm #,ref-to-x))))) - (#%plain-app activation-record-list))))))] - [(#%plain-app call-with-values (#%plain-lambda () prod) cons) - (let ([cons-prime (datum->syntax-object #f (gensym 'cons))]) - (quasisyntax/loc stx - (let-values ([(#,cons-prime) #,(mark-lambda-as-safe (elim-callcc #'cons))]) - #,(markit - (quasisyntax/loc stx - (#%plain-app call-with-values - #,(mark-lambda-as-safe - (quasisyntax/loc stx - (#%plain-lambda () - #,(elim-callcc/mark - (lambda (x) - (quasisyntax/loc stx - (with-continuation-mark the-cont-key #,cons-prime #,x))) - #'prod)))) - #,cons-prime))))))] - [(#%plain-app w (#%plain-app . stuff)) - (with-syntax ([e #'(#%plain-app . stuff)]) - (syntax-case #'w (#%plain-lambda case-lambda) - [(#%plain-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 - (#%plain-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 - (#%plain-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 - (#%plain-app #,w-prime - #,(elim-callcc/mark - (lambda (x) - #`(with-continuation-mark the-cont-key #,w-prime #,x)) - #'e)))))]))] - [(#%plain-app w rest ...) - (markit +#lang scheme/base +(require (lib "kerncase.ss" "syntax") + (for-syntax "../lang/abort-resume.ss") + "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) + (recertify + w + (syntax-case w (#%plain-lambda case-lambda) + [(#%plain-lambda formals be ...) + (syntax/loc w + (#%plain-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) + (recertify + stx + (kernel-syntax-case* + stx (transformer?) (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) + stx] + [(define-values-for-syntax (v ...) ve) + stx] + [(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)] + [(#%plain-lambda formals be) + (with-syntax ([be (elim-callcc #'be)]) + (syntax/loc stx + (#%plain-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))))] + [(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)]) + ; XXX Could be dangerous to evaluate ke-prime and me-prime twice + (markit (quasisyntax/loc stx - (with-continuation-mark safe-call? '(#f stx) - (#%plain-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] - [(#%variable-reference . v) - stx] - [id (identifier? #'id) - stx] - [_ - (raise-syntax-error 'elim-callcc "Dropped through:" stx)])))) \ No newline at end of file + (with-continuation-mark #,ke-prime #,me-prime + (with-continuation-mark + the-save-cm-key + (#%plain-app current-saved-continuation-marks-and #,ke-prime #,me-prime) + #,be-prime)))))] + [(#%expression d) + (markit (quasisyntax/loc stx (#%expression #,(elim-callcc #'d))))] + [(#%plain-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 + (#%plain-app #,(elim-callcc #'w) + (#%plain-app (#%plain-lambda (#,cm) + (#%plain-lambda #,x + (#%plain-app abort + (#%plain-lambda () (#%plain-app resume #,ref-to-cm #,ref-to-x))))) + (#%plain-app activation-record-list))))))] + [(#%plain-app call-with-values (#%plain-lambda () prod) cons) + (let ([cons-prime (datum->syntax #f (gensym 'cons))]) + (quasisyntax/loc stx + (let-values ([(#,cons-prime) #,(mark-lambda-as-safe (elim-callcc #'cons))]) + #,(markit + (quasisyntax/loc stx + (#%plain-app call-with-values + #,(mark-lambda-as-safe + (quasisyntax/loc stx + (#%plain-lambda () + #,(elim-callcc/mark + (lambda (x) + (quasisyntax/loc stx + (with-continuation-mark the-cont-key #,cons-prime #,x))) + #'prod)))) + #,cons-prime))))))] + [(#%plain-app w (#%plain-app . stuff)) + (with-syntax ([e #'(#%plain-app . stuff)]) + (syntax-case #'w (#%plain-lambda case-lambda) + [(#%plain-lambda formals body) + (let ([w-prime (datum->syntax #f (gensym 'l))]) + (quasisyntax/loc stx + (let-values ([(#,w-prime) #,(elim-callcc #'w)]) + #,(markit + (quasisyntax/loc stx + (#%plain-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 #f (gensym 'cl))]) + (quasisyntax/loc stx + (let-values ([(#,w-prime) #,(elim-callcc #'w)]) + #,(markit + (quasisyntax/loc stx + (#%plain-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 + (#%plain-app #,w-prime + #,(elim-callcc/mark + (lambda (x) + #`(with-continuation-mark the-cont-key #,w-prime #,x)) + #'e)))))]))] + [(#%plain-app w rest ...) + (markit + (quasisyntax/loc stx + (with-continuation-mark safe-call? '(#f stx) + (#%plain-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] + [(#%variable-reference . v) + stx] + [id (identifier? #'id) + stx] + [_ + (raise-syntax-error 'elim-callcc "Dropped through:" stx)]))) \ No newline at end of file diff --git a/collects/web-server/lang/elim-letrec.ss b/collects/web-server/lang/elim-letrec.ss index 2d8a492f39..5f12a82679 100644 --- a/collects/web-server/lang/elim-letrec.ss +++ b/collects/web-server/lang/elim-letrec.ss @@ -1,134 +1,128 @@ -(module elim-letrec mzscheme - (require-for-template mzscheme - "../lang/abort-resume.ss") - (require-for-syntax "../lang/abort-resume.ss") - (require (lib "kerncase.ss" "syntax") - (lib "etc.ss") - (lib "list.ss") - "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) - (recertify - stx - (kernel-syntax-case - stx (transformer?) - [(begin be ...) - (with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))]) +#lang scheme/base +(require (lib "kerncase.ss" "syntax") + (lib "etc.ss") + (lib "list.ss") + (for-syntax "../lang/abort-resume.ss") + "util.ss") +(provide (all-defined-out)) + +; 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) + (recertify + stx + (kernel-syntax-case + stx (transformer?) + [(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) + stx] + [(define-values-for-syntax (v ...) ve) + stx] + [(set! v ve) + (with-syntax ([ve ((elim-letrec ids) #'ve)]) + (if (bound-identifier-member? #'id ids) + (syntax/loc stx (#%plain-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 (#%plain-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 - (begin be ...)))] - [(begin0 be ...) - (with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))]) + (let-values ([(v ...) + (#%plain-app values nv-box ...)] ...) + (begin (#%plain-app call-with-values + (#%plain-lambda () ve) + (#%plain-lambda (nv ...) + (#%plain-app set-box! v nv) ...)) + ... + be ...)))))] + [(#%plain-lambda formals be ...) + (with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))]) + (syntax/loc stx + (#%plain-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)))] + [(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 (#%plain-app box the-undef))) + (syntax->list nvs))) + (syntax->list #`((vv ...) ...)))] + [(se ...) (map (elim-letrec new-ids) (syntax->list #'(se ...)))] + [(ve ...) (map (elim-letrec new-ids) (syntax->list #'(ve ...)))] + [(be ...) (map (elim-letrec new-ids) (syntax->list #'(be ...)))]) + ; XXX Optimize special case of one nv (syntax/loc stx - (begin0 be ...)))] - [(define-values (v ...) ve) - (with-syntax ([ve ((elim-letrec ids) #'ve)]) - (syntax/loc stx - (define-values (v ...) ve)))] - [(define-syntaxes (v ...) ve) - stx] - [(define-values-for-syntax (v ...) ve) - stx] - [(set! v ve) - (with-syntax ([ve ((elim-letrec ids) #'ve)]) - (if (bound-identifier-member? #'id ids) - (syntax/loc stx (#%plain-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 (#%plain-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 ...) - (#%plain-app values nv-box ...)] ...) - (begin (#%plain-app call-with-values - (#%plain-lambda () ve) - (#%plain-lambda (nv ...) - (#%plain-app set-box! v nv) ...)) - ... - be ...)))))] - [(#%plain-lambda formals be ...) - (with-syntax ([(be ...) (map (elim-letrec ids) (syntax->list #'(be ...)))]) - (syntax/loc stx - (#%plain-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 (#%plain-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 (#%plain-app box the-undef))) - (syntax->list nvs))) - (syntax->list #`((vv ...) ...)))] - [(se ...) (map (elim-letrec new-ids) (syntax->list #'(se ...)))] - [(ve ...) (map (elim-letrec new-ids) (syntax->list #'(ve ...)))] - [(be ...) (map (elim-letrec new-ids) (syntax->list #'(be ...)))]) - ; XXX Optimize special case of one nv - (syntax/loc stx - (let-values ([(vv ...) - (#%plain-app values nvv-box ...)] ...) - ; This is okay, because we've already expanded the syntax. - (let-syntaxes - ([(sv ...) se] ...) - (begin (#%plain-app call-with-values - (#%plain-lambda () ve) - (#%plain-lambda (nvv ...) - (#%plain-app set-box! vv nvv) ...)) - ... - be ...))))))] - [(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) - (quasisyntax/loc stx (#%expression #,((elim-letrec ids) #'d)))] - [(#%plain-app e ...) - (with-syntax ([(e ...) (map (elim-letrec ids) (syntax->list #'(e ...)))]) - (syntax/loc stx - (#%plain-app e ...)))] - [(#%top . v) - stx] - [(#%variable-reference . v) - stx] - [id (identifier? #'id) - (if (bound-identifier-member? #'id ids) - (syntax/loc stx (#%plain-app unbox id)) - #'id)] - [_ - (raise-syntax-error 'elim-letrec "Dropped through:" stx)]))) - - (define elim-letrec-term (elim-letrec empty))) \ No newline at end of file + (let-values ([(vv ...) + (#%plain-app values nvv-box ...)] ...) + ; This is okay, because we've already expanded the syntax. + (let-syntaxes + ([(sv ...) se] ...) + (begin (#%plain-app call-with-values + (#%plain-lambda () ve) + (#%plain-lambda (nvv ...) + (#%plain-app set-box! vv nvv) ...)) + ... + be ...))))))] + [(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) + (quasisyntax/loc stx (#%expression #,((elim-letrec ids) #'d)))] + [(#%plain-app e ...) + (with-syntax ([(e ...) (map (elim-letrec ids) (syntax->list #'(e ...)))]) + (syntax/loc stx + (#%plain-app e ...)))] + [(#%top . v) + stx] + [(#%variable-reference . v) + stx] + [id (identifier? #'id) + (if (bound-identifier-member? #'id ids) + (syntax/loc stx (#%plain-app unbox id)) + #'id)] + [_ + (raise-syntax-error 'elim-letrec "Dropped through:" stx)]))) + +(define elim-letrec-term (elim-letrec empty)) \ No newline at end of file diff --git a/collects/web-server/lang/freevars.ss b/collects/web-server/lang/freevars.ss index 69bf3b7fb5..9fe9d95ca7 100644 --- a/collects/web-server/lang/freevars.ss +++ b/collects/web-server/lang/freevars.ss @@ -1,144 +1,141 @@ -(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 (transformer?) - [(begin be ...) - (free-vars* (syntax->list #'(be ...)))] - [(begin0 be ...) - (free-vars* (syntax->list #'(be ...)))] - [(define-values (v ...) ve) +#lang scheme/base +(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 (transformer?) + [(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) + (parameterize ([transformer? #t]) (set-diff (free-vars #'ve) - (syntax->list #'(v ...)))] - [(define-syntaxes (v ...) ve) - (parameterize ([transformer? #t]) - (set-diff (free-vars #'ve) - (syntax->list #'(v ...))))] - [(define-values-for-syntax (v ...) ve) - (parameterize ([transformer? #t]) - (set-diff (free-vars #'ve) - (syntax->list #'(v ...))))] - [(set! v ve) - (union (free-vars #'v) - (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 ...) ...)))))] - [(#%plain-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) - (free-vars #'d)] - [(#%plain-app e ...) - (free-vars* (syntax->list #'(e ...)))] - [(#%top . v) - #;(printf "Not including top ~S in freevars~n" (syntax-object->datum #'v)) - empty] - [(#%variable-reference . id) - (let ([i-bdg (identifier-binding #'id)]) - (cond - [(eqv? 'lexical (identifier-binding #'id)) - (list #'id)] - [else - #;(printf "Not including var-reference ~S with binding ~S in freevars~n" (syntax-object->datum #'id) i-bdg) - empty]))] - [id (identifier? #'id) - (let ([i-bdg (identifier-binding #'id)]) - (cond - [(eqv? 'lexical i-bdg) - (list #'id)] - [(not i-bdg) - (list #'id)] - [else - #;(printf "Not including id ~S with binding ~S in freevars~n" (syntax-object->datum #'id) i-bdg) - 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))]))) \ No newline at end of file + (syntax->list #'(v ...))))] + [(define-values-for-syntax (v ...) ve) + (parameterize ([transformer? #t]) + (set-diff (free-vars #'ve) + (syntax->list #'(v ...))))] + [(set! v ve) + (union (free-vars #'v) + (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 ...) ...)))))] + [(#%plain-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)))] + [(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) + (free-vars #'d)] + [(#%plain-app e ...) + (free-vars* (syntax->list #'(e ...)))] + [(#%top . v) + #;(printf "Not including top ~S in freevars~n" (syntax-object->datum #'v)) + empty] + [(#%variable-reference . id) + (let ([i-bdg (identifier-binding #'id)]) + (cond + [(eqv? 'lexical (identifier-binding #'id)) + (list #'id)] + [else + #;(printf "Not including var-reference ~S with binding ~S in freevars~n" (syntax-object->datum #'id) i-bdg) + empty]))] + [id (identifier? #'id) + (let ([i-bdg (identifier-binding #'id)]) + (cond + [(eqv? 'lexical i-bdg) + (list #'id)] + [(not i-bdg) + (list #'id)] + [else + #;(printf "Not including id ~S with binding ~S in freevars~n" (syntax-object->datum #'id) i-bdg) + 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))])) \ No newline at end of file diff --git a/collects/web-server/lang/lang-api.ss b/collects/web-server/lang/lang-api.ss index 93873a798b..20eddb0280 100644 --- a/collects/web-server/lang/lang-api.ss +++ b/collects/web-server/lang/lang-api.ss @@ -1,23 +1,23 @@ -(module lang-api mzscheme - (require (lib "url.ss" "net") - "../private/request-structs.ss" - "../private/response-structs.ss" - "../servlet/helpers.ss" - "abort-resume.ss" - "web.ss" - "web-cells.ss" - "web-param.ss" - "file-box.ss" - "web-extras.ss") - (provide (all-from-except mzscheme #%module-begin) - (all-from (lib "url.ss" "net")) - (all-from "../private/request-structs.ss") - (all-from "../private/response-structs.ss") - (all-from "../servlet/helpers.ss") - ; XXX Try to remove, or only provide send/suspend - (all-from "abort-resume.ss") - (all-from "web.ss") - (all-from "web-cells.ss") - (all-from "web-param.ss") - (all-from "file-box.ss") - (all-from "web-extras.ss"))) \ No newline at end of file +#lang scheme/base +(require (lib "url.ss" "net") + "../private/request-structs.ss" + "../private/response-structs.ss" + "../servlet/helpers.ss" + "abort-resume.ss" + "web.ss" + "web-cells.ss" + "web-param.ss" + "file-box.ss" + "web-extras.ss") +(provide (except-out (all-from-out scheme/base) #%plain-module-begin) + (all-from-out (lib "url.ss" "net")) + (all-from-out "../private/request-structs.ss") + (all-from-out "../private/response-structs.ss") + (all-from-out "../servlet/helpers.ss") + ; XXX Try to remove, or only provide send/suspend + (all-from-out "abort-resume.ss") + (all-from-out "web.ss") + (all-from-out "web-cells.ss") + (all-from-out "web-param.ss") + (all-from-out "file-box.ss") + (all-from-out "web-extras.ss")) \ No newline at end of file diff --git a/collects/web-server/lang/util.ss b/collects/web-server/lang/util.ss index bc55695dfb..339f0fc54e 100644 --- a/collects/web-server/lang/util.ss +++ b/collects/web-server/lang/util.ss @@ -1,219 +1,209 @@ -(module util mzscheme - (require-for-template mzscheme) - (require (lib "kerncase.ss" "syntax") - (lib "list.ss")) - (provide (all-defined-except template)) - - (define transformer? (make-parameter #f)) - - (define (recertify old-expr expr) - (syntax-recertify expr old-expr (current-code-inspector) #f)) - - (define (recertify* old-expr exprs) - (map (lambda (expr) - (syntax-recertify expr old-expr (current-code-inspector) #f)) - exprs)) - - (define (recertify/new-defs old-expr thunk) - (call-with-values - thunk - (lambda (expr new-defs) - (values (recertify old-expr expr) - (recertify* old-expr new-defs))))) - - (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) - (recertify - stx - (syntax-case stx (define-values define-syntaxes define-values-for-syntax) - [(define-values (v ...) ve) +#lang scheme/base +(require (lib "kerncase.ss" "syntax") + (lib "list.ss")) +(provide (except-out (all-defined-out) template)) + +(define transformer? (make-parameter #f)) + +(define (recertify old-expr expr) + (syntax-recertify expr old-expr (current-code-inspector) #f)) + +(define (recertify* old-expr exprs) + (map (lambda (expr) + (syntax-recertify expr old-expr (current-code-inspector) #f)) + exprs)) + +(define (recertify/new-defs old-expr thunk) + (call-with-values + thunk + (lambda (expr new-defs) + (values (recertify old-expr expr) + (recertify* old-expr new-defs))))) + +(define current-code-labeling + (make-parameter + (lambda (stx) + (datum->syntax stx 'error)))) + +(define (generate-formal sym-name) + (let ([name (datum->syntax #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) + (recertify + 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) + (parameterize ([transformer? #t]) (with-syntax ([ve (inner #'ve)]) (syntax/loc stx - (define-values (v ...) ve)))] - [(define-syntaxes (v ...) ve) - (parameterize ([transformer? #t]) - (with-syntax ([ve (inner #'ve)]) - (syntax/loc stx - (define-syntaxes (v ...) ve))))] - [(define-values-for-syntax (v ...) ve) - (parameterize ([transformer? #t]) - (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) - (recertify* - 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) - (recertify - 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)]))) - - (define ((make-lang-module-begin make-labeling transform) stx) - (recertify - stx - (syntax-case stx () - ((mb forms ...) - (with-syntax ([(pmb rfs0 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 rfs0 - #,@new-defs)))))))))) - - (define (bound-identifier-member? id ids) - (ormap - (lambda (an-id) - (bound-identifier=? id an-id)) - ids)) - - ;; Kernel Case Template - (define (template stx) - (recertify - stx - (kernel-syntax-case - stx (transformer?) - [(begin be ...) - (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) + (define-syntaxes (v ...) ve))))] + [(define-values-for-syntax (v ...) ve) + (parameterize ([transformer? #t]) + (with-syntax ([ve (inner #'ve)]) (syntax/loc stx - (begin be ...)))] - [(begin0 be ...) - (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) - (syntax/loc stx - (begin0 be ...)))] - [(define-values (v ...) ve) + (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) + (recertify* + stx + (syntax-case* stx (#%require #%provide) free-identifier=? + [(#%require spec ...) + (list stx)] + [(#%provide spec ...) + (list stx)] + [_ + (inner stx)]))) + +(define ((make-module-case inner) stx) + (recertify + stx + (syntax-case* stx (#%require #%provide) free-identifier=? + [(#%require spec ...) + stx] + [(#%provide spec ...) + stx] + [_ + (inner stx)]))) + +(define ((make-lang-module-begin make-labeling transform) stx) + (recertify + stx + (syntax-case stx () + ((mb forms ...) + (with-syntax ([(pmb rfs0 body ...) + (local-expand (quasisyntax/loc stx + (#%plain-module-begin + #,(syntax-local-introduce + #'(require (for-syntax scheme/base))) + forms ...)) + 'module-begin + empty)]) + (let ([base-labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax->datum stx))))]) + (parameterize ([current-code-labeling + (lambda (stx) + (datum->syntax stx (base-labeling)))]) + (let ([new-defs (apply append (map transform (syntax->list #'(body ...))))]) + (quasisyntax/loc stx + (pmb rfs0 + #,@new-defs)))))))))) + +(define (bound-identifier-member? id ids) + (ormap + (lambda (an-id) + (bound-identifier=? id an-id)) + ids)) + +;; Kernel Case Template +(define (template stx) + (recertify + stx + (kernel-syntax-case + stx (transformer?) + [(begin be ...) + (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) + (syntax/loc stx + (begin be ...)))] + [(begin0 be ...) + (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) + (syntax/loc stx + (begin0 be ...)))] + [(define-values (v ...) ve) + (with-syntax ([ve (template #'ve)]) + (syntax/loc stx + (define-values (v ...) ve)))] + [(define-syntaxes (v ...) ve) + (parameterize ([transformer? #t]) (with-syntax ([ve (template #'ve)]) (syntax/loc stx - (define-values (v ...) ve)))] - [(define-syntaxes (v ...) ve) - (parameterize ([transformer? #t]) - (with-syntax ([ve (template #'ve)]) - (syntax/loc stx - (define-syntaxes (v ...) ve))))] - [(define-values-for-syntax (v ...) ve) - (parameterize ([transformer? #t]) - (with-syntax ([ve (template #'ve)]) - (syntax/loc stx - (define-values-for-syntax (v ...) ve))))] - [(set! v ve) + (define-syntaxes (v ...) ve))))] + [(define-values-for-syntax (v ...) ve) + (parameterize ([transformer? #t]) (with-syntax ([ve (template #'ve)]) - (syntax/loc stx - (set! v ve)))] - [(let-values ([(v ...) ve] ...) be ...) - (with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))] - [(be ...) (map template (syntax->list #'(be ...)))]) - (syntax/loc stx - (let-values ([(v ...) ve] ...) be ...)))] - [(letrec-values ([(v ...) ve] ...) be ...) - (with-syntax ([(ve ...) (map template (syntax->list #'(ve ...)))] - [(be ...) (map template (syntax->list #'(be ...)))]) - (syntax/loc stx - (letrec-values ([(v ...) ve] ...) be ...)))] - [(#%plain-lambda formals be ...) - (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) - (syntax/loc stx - (#%plain-lambda formals be ...)))] - [(case-lambda [formals be ...] ...) - (with-syntax ([((be ...) ...) (map template (syntax->list #'((be ...) ...)))]) - (syntax/loc stx - (case-lambda [formals be ...] ...)))] - [(if te ce ae) - (with-syntax ([te (template #'te)] - [ce (template #'ce)] - [ae (template #'ae)]) - (syntax/loc stx - (if te ce ae)))] - [(if te ce) - (template (syntax/loc stx (if te ce (#%plain-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] - [(#%plain-app e ...) - (with-syntax ([(e ...) (map template (syntax->list #'(e ...)))]) - (syntax/loc stx - (#%plain-app e ...)))] - [(#%top . v) - stx] - [(#%variable-reference . v) - stx] - [id (identifier? #'id) - stx] - [_ - (raise-syntax-error 'kerncase "Dropped through:" stx)])))) \ No newline at end of file + (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 ...)))] + [(#%plain-lambda formals be ...) + (with-syntax ([(be ...) (map template (syntax->list #'(be ...)))]) + (syntax/loc stx + (#%plain-lambda formals be ...)))] + [(case-lambda [formals be ...] ...) + (with-syntax ([((be ...) ...) (map template (syntax->list #'((be ...) ...)))]) + (syntax/loc stx + (case-lambda [formals be ...] ...)))] + [(if te ce ae) + (with-syntax ([te (template #'te)] + [ce (template #'ce)] + [ae (template #'ae)]) + (syntax/loc stx + (if te ce ae)))] + [(quote datum) + stx] + [(quote-syntax datum) + stx] + [(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] + [(#%plain-app e ...) + (with-syntax ([(e ...) (map template (syntax->list #'(e ...)))]) + (syntax/loc stx + (#%plain-app e ...)))] + [(#%top . v) + stx] + [(#%variable-reference . v) + stx] + [id (identifier? #'id) + stx] + [_ + (raise-syntax-error 'kerncase "Dropped through:" stx)]))) \ No newline at end of file diff --git a/collects/web-server/lang/web-param.ss b/collects/web-server/lang/web-param.ss index 444a466df7..6ff9acbc7d 100644 --- a/collects/web-server/lang/web-param.ss +++ b/collects/web-server/lang/web-param.ss @@ -1,55 +1,57 @@ -(module web-param mzscheme - (require "../private/closure.ss" - (lib "list.ss")) - ; XXX Add contract - (provide make-web-parameter - 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 ...)))]))) +#lang scheme/base +(require (for-syntax scheme/base) + "../private/closure.ss" + (lib "list.ss")) + +; XXX Add contract +(provide make-web-parameter + 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 ...)))])) \ No newline at end of file diff --git a/collects/web-server/private/closure.ss b/collects/web-server/private/closure.ss index 41b01484fb..4c842e4aff 100644 --- a/collects/web-server/private/closure.ss +++ b/collects/web-server/private/closure.ss @@ -1,128 +1,126 @@ -(module closure mzscheme - (require-for-template mzscheme - (lib "serialize.ss") - (lib "etc.ss")) - (require (lib "list.ss") - (lib "serialize.ss")) - (provide make-closure-definition-syntax - closure->deserialize-name) - - (define (closure->deserialize-name proc) - (cdr (first (second (serialize proc))))) - - ;; borrowed this from Matthew's code - ;; creates the deserialize-info identifier - (define (make-deserialize-name id) - (datum->syntax-object - id - (string->symbol - (format "web-deserialize-info:~a" (syntax-e id))) - id)) - - (define (make-closure-definition-syntax tag fvars proc) - (let ([make-id (lambda (str) - (datum->syntax-object - tag (string->symbol (format str (syntax-object->datum tag)))))]) - (let ([deserialize-info:CLOSURE (make-deserialize-name tag)]) - (with-syntax ([CLOSURE:serialize-info (make-id "~a:serialize-info")] - [make-CLOSURE (make-id "make-~a")] - [CLOSURE? (make-id "~a?")] - [CLOSURE-ref (make-id "~a-ref")] - [CLOSURE-set! (make-id "~a-set!")] - [CLOSURE-env (make-id "~a-env")] - [set-CLOSURE-env! (make-id "set-~a-env!")] - [struct:CLOSURE (make-id "struct:~a")]) - (values - (syntax/loc proc make-CLOSURE) - (list - (quasisyntax/loc proc - (define #,deserialize-info:CLOSURE - (make-deserialize-info - - ;; make-proc: value ... -> CLOSURE - (lambda args - (apply #,(if (null? fvars) - (syntax/loc proc (lambda () (make-CLOSURE))) - (quasisyntax/loc proc (lambda #,fvars (make-CLOSURE (lambda () (values #,@fvars)))))) - args)) - - ;; cycle-make-proc: -> (values CLOSURE (CLOSURE -> void)) - (lambda () - (let ([new-closure - #,(if (null? fvars) - (syntax/loc proc (make-CLOSURE)) - (syntax/loc proc (make-CLOSURE (lambda () (error "closure not initialized")))))]) - (values - new-closure - #,(if (null? fvars) - (syntax/loc proc void) - (syntax/loc proc - (lambda (clsr) - (set-CLOSURE-env! new-closure (CLOSURE-env clsr))))))))))) - - (quasisyntax/loc proc - (provide #,deserialize-info:CLOSURE)) - - (quasisyntax/loc proc - (define CLOSURE:serialize-info - (make-serialize-info - - ;; to-vector: CLOSURE -> vector +#lang scheme/base +(require (for-template scheme/base) + (for-template (lib "serialize.ss")) + (lib "list.ss") + (lib "serialize.ss")) +(provide make-closure-definition-syntax + closure->deserialize-name) + +(define (closure->deserialize-name proc) + (cdr (first (second (serialize proc))))) + +(define (make-closure-definition-syntax tag fvars proc) + (define (make-id str) + (datum->syntax tag (string->symbol (format str (syntax->datum tag))))) + (with-syntax ([CLOSURE:deserialize-info (make-id "~a:deserialize-info")] + [CLOSURE:serialize-info (make-id "~a:serialize-info")] + [make-CLOSURE (make-id "make-~a")] + [CLOSURE? (make-id "~a?")] + [CLOSURE-ref (make-id "~a-ref")] + [CLOSURE-set! (make-id "~a-set!")] + [CLOSURE-env (make-id "~a-env")] + [set-CLOSURE-env! (make-id "set-~a-env!")] + [struct:CLOSURE (make-id "struct:~a")]) + (values + (syntax/loc proc make-CLOSURE) + (list + (quasisyntax/loc proc + (define CLOSURE:deserialize-info + (make-deserialize-info + + ;; make-proc: value ... -> CLOSURE + (lambda args + (apply #,(if (null? fvars) + (syntax/loc proc + (#%plain-lambda () (#%plain-app make-CLOSURE))) + (quasisyntax/loc proc + (#%plain-lambda #,fvars + (#%plain-app make-CLOSURE + (#%plain-lambda () + (#%plain-app values #,@fvars)))))) + args)) + + ;; cycle-make-proc: -> (values CLOSURE (CLOSURE -> void)) + (lambda () + (let ([new-closure + #,(if (null? fvars) + (syntax/loc proc (#%plain-app make-CLOSURE)) + (syntax/loc proc + (#%plain-app make-CLOSURE + (#%plain-lambda () (#%plain-app error "closure not initialized")))))]) + (values + new-closure + #,(if (null? fvars) + (syntax/loc proc void) + (syntax/loc proc + (#%plain-lambda (clsr) + (#%plain-app set-CLOSURE-env! new-closure (#%plain-app CLOSURE-env clsr))))))))))) + + (quasisyntax/loc proc + (provide CLOSURE:deserialize-info)) + + (quasisyntax/loc proc + (define CLOSURE:serialize-info + (make-serialize-info + + ;; to-vector: CLOSURE -> vector + #,(if (null? fvars) + (syntax/loc proc (#%plain-lambda (clsr) (#%plain-app vector))) + (syntax/loc proc + (#%plain-lambda (clsr) + (#%plain-app call-with-values + (#%plain-lambda () (#%plain-app (#%plain-app CLOSURE-env clsr))) + vector)))) + + ;; The serializer id: -------------------- + ;(syntax deserialize-info:CLOSURE) + ;; I still don't know what to put here. + ;; oh well. + ;(quote-syntax #,(syntax deserialize-info:CLOSURE)) + (let ([b (identifier-binding (quote-syntax CLOSURE:deserialize-info))]) + (if (list? b) + (cons 'CLOSURE:deserialize-info (caddr b)) + 'CLOSURE:deserialize-info)) + + ;; can-cycle? + #t + + ;; Directory for last-ditch resolution -------------------- + (or (current-load-relative-directory) (current-directory)) + ))) + + (quasisyntax/loc proc + (define-values (struct:CLOSURE make-CLOSURE CLOSURE? + #,@(if (null? fvars) + (syntax/loc proc ()) + (syntax/loc proc (CLOSURE-env set-CLOSURE-env!)))) + (let ([struct-apply #,(if (null? fvars) - (syntax/loc proc (lambda (clsr) (vector))) - (syntax/loc proc - (lambda (clsr) - (call-with-values - (lambda () ((CLOSURE-env clsr))) - vector)))) - - ;; The serializer id: -------------------- - ;(syntax deserialize-info:CLOSURE) - ;; I still don't know what to put here. - ;; oh well. - ;(quote-syntax #,(syntax deserialize-info:CLOSURE)) - (let ([b (identifier-binding (quote-syntax #,deserialize-info:CLOSURE))]) - (if (list? b) - (cons '#,deserialize-info:CLOSURE (caddr b)) - '#,deserialize-info:CLOSURE)) - - ;; can-cycle? - #t - - ;; Directory for last-ditch resolution -------------------- - (or (current-load-relative-directory) (current-directory)) - ))) - - (quasisyntax/loc proc - (define-values (struct:CLOSURE make-CLOSURE CLOSURE? - #,@(if (null? fvars) - (syntax/loc proc ()) - (syntax/loc proc (CLOSURE-env set-CLOSURE-env!)))) - (let-values ([(struct:CLOSURE make-CLOSURE CLOSURE? CLOSURE-ref CLOSURE-set!) - (make-struct-type '#,tag ;; the tag goes here - #f ; no super type - #,(if (null? fvars) 0 1) - 0 ; number of auto-fields - #f ; auto-v - - ; prop-vals: - (list (cons prop:serializable CLOSURE:serialize-info)) - - #f ; inspector - - ;; the struct apply proc: - #,(if (null? fvars) - (quasisyntax/loc proc - (lambda (clsr . args) - (apply #,proc args))) - (quasisyntax/loc proc - (lambda (clsr . args) - (let-values ([#,fvars ((CLOSURE-env clsr))]) - (apply #,proc args))))) - )]) - (values struct:CLOSURE make-CLOSURE CLOSURE? - #,@(if (null? fvars) - (syntax/loc proc ()) - (syntax/loc proc - ((lambda (clsr) (CLOSURE-ref clsr 0)) - (lambda (clsr new-env) (CLOSURE-set! clsr 0 new-env)))))))))))))))) \ No newline at end of file + (quasisyntax/loc proc + (#%plain-lambda (clsr . args) + (#%plain-app apply #,proc args))) + (quasisyntax/loc proc + (#%plain-lambda (clsr . args) + (let-values ([#,fvars (#%plain-app (#%plain-app CLOSURE-env clsr))]) + (#%plain-app apply #,proc args)))))]) + (let-values ([(struct:CLOSURE make-CLOSURE CLOSURE? CLOSURE-ref CLOSURE-set!) + (make-struct-type '#,tag ;; the tag goes here + #f ; no super type + #,(if (null? fvars) 0 1) + 0 ; number of auto-fields + #f ; auto-v + + ; prop-vals: + (list (cons prop:serializable CLOSURE:serialize-info) + (cons prop:procedure struct-apply)) + + #f ; inspector + + ;; the struct apply proc: + #f)]) + (values struct:CLOSURE make-CLOSURE CLOSURE? + #,@(if (null? fvars) + (syntax/loc proc ()) + (syntax/loc proc + ((#%plain-lambda (clsr) (#%plain-app CLOSURE-ref clsr 0)) + (#%plain-lambda (clsr new-env) (#%plain-app CLOSURE-set! clsr 0 new-env)))))))))))))) \ No newline at end of file diff --git a/collects/web-server/private/mod-map.ss b/collects/web-server/private/mod-map.ss index 39a3fffea2..dcbe7037e7 100644 --- a/collects/web-server/private/mod-map.ss +++ b/collects/web-server/private/mod-map.ss @@ -48,11 +48,11 @@ ; compress-serial : serial -> serial (with compressed mod-map) (define compress-serial (match-lambda - [(list e0 mm e2 e3 e4 e5) - (list e0 (compress-mod-map mm) e2 e3 e4 e5)])) + [(list vs e0 mm e2 e3 e4 e5) + (list vs e0 (compress-mod-map mm) e2 e3 e4 e5)])) ; decompress-serial : serial (with compressed mod-map) -> serial (define decompress-serial (match-lambda - [(list e0 cmm e2 e3 e4 e5) - (list e0 (decompress-mod-map cmm) e2 e3 e4 e5)]))) \ No newline at end of file + [(list vs e0 cmm e2 e3 e4 e5) + (list vs e0 (decompress-mod-map cmm) e2 e3 e4 e5)]))) \ No newline at end of file diff --git a/collects/web-server/tests/dispatchers/dispatch-lang-test.ss b/collects/web-server/tests/dispatchers/dispatch-lang-test.ss index fcd9c829d6..4616132284 100644 --- a/collects/web-server/tests/dispatchers/dispatch-lang-test.ss +++ b/collects/web-server/tests/dispatchers/dispatch-lang-test.ss @@ -1,6 +1,7 @@ (module dispatch-lang-test mzscheme (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) - #;(planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4)) + ; XXX Replace with real + (lib "sxml.ss" "web-server/tmp/sxml") (lib "etc.ss") (lib "list.ss") (lib "dispatch.ss" "web-server" "dispatchers") @@ -10,9 +11,6 @@ "../util.ss") (provide dispatch-lang-tests) - ; XXX Sxpath broken - (define sxpath (lambda _ (lambda _ (error 'sxpath)))) - (define (mkd p) (lang:make #:url->path (lambda _ (values p (list p))) #:make-servlet-namespace diff --git a/collects/web-server/tests/dispatchers/dispatch-servlets-test.ss b/collects/web-server/tests/dispatchers/dispatch-servlets-test.ss index 258cdbe6cb..492423abd2 100644 --- a/collects/web-server/tests/dispatchers/dispatch-servlets-test.ss +++ b/collects/web-server/tests/dispatchers/dispatch-servlets-test.ss @@ -1,6 +1,7 @@ (module dispatch-servlets-test mzscheme (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) - #;(planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4)) + ; XXX Replace with real + (lib "sxml.ss" "web-server/tmp/sxml") (lib "etc.ss") (lib "list.ss") (lib "request-structs.ss" "web-server" "private") @@ -10,10 +11,7 @@ (prefix servlets: (lib "dispatch-servlets.ss" "web-server" "dispatchers")) "../util.ss") (provide dispatch-servlets-tests) - - ; XXX Sxpath broken - (define sxpath (lambda _ (lambda _ (error 'sxpath)))) - + (current-server-custodian (current-custodian)) (define (mkd p) diff --git a/collects/web-server/tests/util.ss b/collects/web-server/tests/util.ss index 2635fe6422..73f4ce399d 100644 --- a/collects/web-server/tests/util.ss +++ b/collects/web-server/tests/util.ss @@ -1,6 +1,7 @@ (module util mzscheme (require (lib "connection-manager.ss" "web-server" "private") - #;(only (planet "ssax.ss" ("lizorkin" "ssax.plt" 1 3)) + ; XXX Replace with real + (only (lib "ssax.ss" "web-server/tmp/ssax") ssax:xml->sxml) (lib "request-structs.ss" "web-server" "private") (lib "web-server-structs.ss" "web-server" "private") @@ -19,9 +20,7 @@ (define (call d u bs) (htxml (collect d (make-request 'get (string->url u) empty bs #"" "127.0.0.1" 80 "127.0.0.1")))) (define (htxml bs) - ; XXX SSAX is broken - #;(define sx (ssax:xml->sxml (open-input-bytes (second (regexp-match #"^.+\r\n\r\n(.+)$" bs))) empty)) - (define sx empty) + (define sx (ssax:xml->sxml (open-input-bytes (second (regexp-match #"^.+\r\n\r\n(.+)$" bs))) empty)) (pretty-print sx) sx) diff --git a/collects/web-server/tmp/htmlprag/doc.txt b/collects/web-server/tmp/htmlprag/doc.txt new file mode 100644 index 0000000000..a836bf264b --- /dev/null +++ b/collects/web-server/tmp/htmlprag/doc.txt @@ -0,0 +1,422 @@ +HtmlPrag: Pragmatic Parsing and Emitting of HTML using SXML and SHTML +********************************************************************* + +Version 0.16, 2005-12-18, `http://www.neilvandyke.org/htmlprag/' + +by Neil W. Van Dyke + + Copyright (C) 2003 - 2005 Neil W. Van Dyke. This program is Free + Software; you can redistribute it and/or modify it under the terms + of the GNU Lesser General Public License as published by the Free + Software Foundation; either version 2.1 of the License, or (at + your option) any later version. This program is distributed in + the hope that it will be useful, but without any warranty; without + even the implied warranty of merchantability or fitness for a + particular purpose. See + for details. For other license options and consulting, contact + the author. + +Introduction +************ + +HtmlPrag provides permissive HTML parsing and emitting capability to +Scheme programs. The parser is useful for software agent extraction of +information from Web pages, for programmatically transforming HTML +files, and for implementing interactive Web browsers. HtmlPrag emits +"SHTML," which is an encoding of HTML in SXML +(http://pobox.com/~oleg/ftp/Scheme/SXML.html), so that conventional +HTML may be processed with XML tools such as SXPath +(http://pair.com/lisovsky/query/sxpath/). Like Oleg Kiselyov's +SSAX-based HTML parser +(http://pobox.com/~oleg/ftp/Scheme/xml.html#HTML-parser), HtmlPrag +provides a permissive tokenizer, but also attempts to recover +structure. HtmlPrag also includes procedures for encoding SHTML in +HTML syntax. + + The HtmlPrag parsing behavior is permissive in that it accepts +erroneous HTML, handling several classes of HTML syntax errors +gracefully, without yielding a parse error. This is crucial for +parsing arbitrary real-world Web pages, since many pages actually +contain syntax errors that would defeat a strict or validating parser. +HtmlPrag's handling of errors is intended to generally emulate popular +Web browsers' interpretation of the structure of erroneous HTML. We +euphemistically term this kind of parse "pragmatic." + + HtmlPrag also has some support for XHTML, although XML namespace +qualifiers are currently accepted but stripped from the resulting +SHTML. Note that valid XHTML input is of course better handled by a +validating XML parser like Kiselyov's SSAX +(http://pobox.com/~oleg/ftp/Scheme/xml.html#XML-parser). + + HtmlPrag requires R5RS, SRFI-6, and SRFI-23. + +SHTML and SXML +************** + +SHTML is a variant of SXML, with two minor but useful extensions: + + 1. The SXML keyword symbols, such as `*TOP*', are defined to be in all + uppercase, regardless of the case-sensitivity of the reader of the + hosting Scheme implementation in any context. This avoids several + pitfalls. + + 2. Since not all character entity references used in HTML can be + converted to Scheme characters in all R5RS Scheme implementations, + nor represented in conventional text files or other common + external text formats to which one might wish to write SHTML, + SHTML adds a special `&' syntax for non-ASCII (or + non-Extended-ASCII) characters. The syntax is `(& VAL)', where + VAL is a symbol or string naming with the symbolic name of the + character, or an integer with the numeric value of the character. + + +> shtml-comment-symbol +> shtml-decl-symbol +> shtml-empty-symbol +> shtml-end-symbol +> shtml-entity-symbol +> shtml-pi-symbol +> shtml-start-symbol +> shtml-text-symbol +> shtml-top-symbol + These variables are bound to the following case-sensitive symbols + used in SHTML, respectively: `*COMMENT*', `*DECL*', `*EMPTY*', + `*END*', `*ENTITY*', `*PI*', `*START*', `*TEXT*', and `*TOP*'. + These can be used in lieu of the literal symbols in programs read + by a case-insensitive Scheme reader.(1) + +> shtml-named-char-id +> shtml-numeric-char-id + These variables are bound to the SHTML entity public identifier + strings used in SHTML `*ENTITY*' named and numeric character entity + references. + +> (make-shtml-entity val) + Yields an SHTML character entity reference for VAL. For example: + + (make-shtml-entity "rArr") => (& rArr) + (make-shtml-entity (string->symbol "rArr")) => (& rArr) + (make-shtml-entity 151) => (& 151) + +> (shtml-entity-value obj) + Yields the value for the SHTML entity OBJ, or `#f' if OBJ is not a + recognized entity. Values of named entities are symbols, and + values of numeric entities are numbers. An error may raised if OBJ + is an entity with system ID inconsistent with its public ID. For + example: + + (define (f s) (shtml-entity-value (cadr (html->shtml s)))) + (f " ") => nbsp + (f "ߐ") => 2000 + +Tokenizing +********** + +The tokenizer is used by the higher-level structural parser, but can +also be called directly for debugging purposes or unusual applications. +Some of the list structure of tokens, such as for start tag tokens, is +mutated and incorporated into the SHTML list structure emitted by the +parser. + +> (make-html-tokenizer in normalized?) + Constructs an HTML tokenizer procedure on input port IN. If + boolean NORMALIZED? is true, then tokens will be in a format + conducive to use with a parser emitting normalized SXML. Each + call to the resulting procedure yields a successive token from the + input. When the tokens have been exhausted, the procedure returns + the null list. For example: + + (define input (open-input-string "bar")) + (define next (make-html-tokenizer input #f)) + (next) => (a (@ (href "foo"))) + (next) => "bar" + (next) => (*END* a) + (next) => () + (next) => () + +> (tokenize-html in normalized?) + Returns a list of tokens from input port IN, normalizing according + to boolean NORMALIZED?. This is probably most useful as a + debugging convenience. For example: + + (tokenize-html (open-input-string "bar") #f) + => ((a (@ (href "foo"))) "bar" (*END* a)) + +> (shtml-token-kind token) + Returns a symbol indicating the kind of tokenizer TOKEN: + `*COMMENT*', `*DECL*', `*EMPTY*', `*END*', `*ENTITY*', `*PI*', + `*START*', `*TEXT*'. This is used by higher-level parsing code. + For example: + + (map shtml-token-kind + (tokenize-html (open-input-string "> (*START* *START* *TEXT* *START* *END* *END*) + +Parsing +******* + +Most applications will call a parser procedure such as `html->shtml' +rather than calling the tokenizer directly. + +> (parse-html/tokenizer tokenizer normalized?) + Emits a parse tree like `html->shtml' and related procedures, + except using TOKENIZER as a source of tokens, rather than + tokenizing from an input port. This procedure is used internally, + and generally should not be called directly. + +> (html->sxml-0nf input) +> (html->sxml-1nf input) +> (html->sxml-2nf input) +> (html->sxml input) +> (html->shtml input) + Permissively parse HTML from INPUT, which is either an input port + or a string, and emit an SHTML equivalent or approximation. To + borrow and slightly modify an example from Kiselyov's discussion + of his HTML parser: + + (html->shtml + "whatever + link