From d9be3d0c4bf372c7db8f3515590ae224f8ba2e6b Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 5 Nov 2008 23:09:14 +0000 Subject: [PATCH] Improving contracts on web lang svn: r12322 --- .../web-server/lang/abort-resume-test.ss | 12 ++-- collects/web-server/lang/abort-resume.ss | 71 ++++++++++++------- collects/web-server/lang/defun.ss | 17 +---- collects/web-server/lang/elim-callcc.ss | 7 +- 4 files changed, 52 insertions(+), 55 deletions(-) diff --git a/collects/tests/web-server/lang/abort-resume-test.ss b/collects/tests/web-server/lang/abort-resume-test.ss index b538502532..4fc8d58b07 100644 --- a/collects/tests/web-server/lang/abort-resume-test.ss +++ b/collects/tests/web-server/lang/abort-resume-test.ss @@ -74,21 +74,21 @@ (check-equal? (abort/cc (lambda () (let/ec esc - ('f1 (with-continuation-mark the-cont-key 'f1 + ('f1 (with-continuation-mark the-cont-key + (esc (activation-record-list))))))) - (list (vector 'f1 #f)))) + (list (vector + #f)))) (test-case "Double" (check-equal? (abort/cc (lambda () (let/ec esc - ('f1 (with-continuation-mark the-cont-key 'f1 - ('f2 (with-continuation-mark the-cont-key 'f2 + ('f1 (with-continuation-mark the-cont-key + + ('f2 (with-continuation-mark the-cont-key - (esc (activation-record-list))))))))) ; Opposite the order of c-c-m - (list (vector 'f1 #f) - (vector 'f2 #f)))) + (list (vector + #f) + (vector - #f)))) (test-case "Unsafe" diff --git a/collects/web-server/lang/abort-resume.ss b/collects/web-server/lang/abort-resume.ss index 4a378cff7c..ecaf54e824 100644 --- a/collects/web-server/lang/abort-resume.ss +++ b/collects/web-server/lang/abort-resume.ss @@ -1,30 +1,7 @@ -#lang scheme/base -(require mzlib/list - mzlib/plt-match - mzlib/serialize +#lang scheme +(require scheme/serialize "../private/define-closure.ss" "../lang/web-cells.ss") -; XXX contract -(provide - - ;; AUXILLIARIES - abort - abort/cc - resume - the-cont-key - the-save-cm-key - safe-call? - the-undef - activation-record-list - current-saved-continuation-marks-and - kont-append-fun - - ;; "SERVLET" INTERFACE - send/suspend - - ;; "CLIENT" INTERFACE - dispatch-start - dispatch) ;; ********************************************************************** ;; ********************************************************************** @@ -33,7 +10,7 @@ (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 web-prompt (make-continuation-prompt-tag 'web)) (define (current-saved-continuation-marks-and key val) (define c @@ -62,7 +39,7 @@ ;; erase the stack and apply a thunk (define (abort thunk) #;(printf "abort ~S~n" thunk) - (abort-current-continuation web-prompt thunk)) + (abort-current-continuation web-prompt thunk)) ;; with-continuation-marks : (listof (cons any1 any2)) (-> any3) -> any3 (define (with-continuation-marks cms thnk) @@ -172,3 +149,43 @@ => (lambda (k) (k req))] [else (error 'dispatch "no continuation associated with the provided request: ~S" req)])))) + +;; ********************************************************************** +;; ********************************************************************** + +; These should really be from web-server/private, but it interferes with testing +(define request? any/c) +(define response? any/c) + +(define cms? (and/c hash? immutable?)) + +(define saved-context? + (listof (vector/c (or/c false/c procedure?) + (or/c false/c cms?)))) + +(provide/contract + ;; AUXILLIARIES + [abort ((-> any) . -> . any)] + [abort/cc ((-> any) . -> . any)] + [resume (saved-context? any/c . -> . any)] + [the-cont-key mark-key?] + [the-save-cm-key mark-key?] + [safe-call? mark-key?] + [the-undef undef?] + [activation-record-list (-> saved-context?)] + [current-saved-continuation-marks-and (any/c any/c . -> . cms?)] + [kont-append-fun (kont? procedure? . -> . kont?)] + + ;; "CLIENT" INTERFACE + [dispatch ((request? . -> . (request? . -> . response?)) + request? + . -> . + response?)] + [dispatch-start ((request? . -> . response?) + request? + . -> . + response?)]) +(provide + ;; "SERVLET" INTERFACE + ; A contract would interfere with the safe-call? key + send/suspend) \ No newline at end of file diff --git a/collects/web-server/lang/defun.ss b/collects/web-server/lang/defun.ss index 72f9cf7bbc..da54fe69c4 100644 --- a/collects/web-server/lang/defun.ss +++ b/collects/web-server/lang/defun.ss @@ -100,22 +100,7 @@ empty)] [id (identifier? #'id) (values stx - empty)] - ; XXX Shouldn't - [(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))))] + empty)] [(#%expression d) (let-values ([(nd d-defs) (defun #'d)]) (values (quasisyntax/loc stx (#%expression #,nd)) diff --git a/collects/web-server/lang/elim-callcc.ss b/collects/web-server/lang/elim-callcc.ss index eef819d3fe..dac6d1b22c 100644 --- a/collects/web-server/lang/elim-callcc.ss +++ b/collects/web-server/lang/elim-callcc.ss @@ -163,12 +163,7 @@ [(#%variable-reference . v) stx] [id (identifier? #'id) - stx] - ; XXX Shouldn't - [(letrec-syntaxes+values ([(sv ...) se] ...) - ([(vv ...) ve] ...) - be ...) - (raise-syntax-error 'elim-callcc/mark "Not in ANF" stx)] + stx] [(#%expression d) (markit (quasisyntax/loc stx (#%expression #,(elim-callcc #'d))))] [_