diff --git a/collects/tests/web-server/lang/abort-resume-test.ss b/collects/tests/web-server/lang/abort-resume-test.ss index 0c4ce62f85..b30891e6e7 100644 --- a/collects/tests/web-server/lang/abort-resume-test.ss +++ b/collects/tests/web-server/lang/abort-resume-test.ss @@ -2,6 +2,7 @@ (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) (planet "util.ss" ("schematics" "schemeunit.plt" 2)) web-server/lang/abort-resume) +(require/expose web-server/lang/abort-resume (web-prompt)) (provide abort-resume-tests) (define abort-resume-tests @@ -9,52 +10,146 @@ "Abort/Resume" (test-suite - "current-saved-continuation-marks-and" - - (test-case - "Not in prompt" - (check-exn exn? (lambda () (current-saved-continuation-marks-and 'k1 'v1)))) + "with-current-saved-continuation-marks-and" (test-case "Easy" - (check-equal? (call-with-web-prompt - (lambda () (current-saved-continuation-marks-and 'k1 'v1))) - (make-immutable-hash (list (cons 'k1 'v1))))) + (check-equal? + (call-with-web-prompt + (lambda () + (with-current-saved-continuation-marks-and + 'k1 'v1 + (lambda () + (continuation-mark-set->list + (current-continuation-marks web-prompt) + the-save-cm-key))))) + (list (make-immutable-hash (list (cons 'k1 'v1)))))) (test-case - "Preserve" - (check-equal? (call-with-web-prompt - (lambda () - (with-continuation-mark the-save-cm-key (make-immutable-hash (list (cons 'k2 'v2))) - (current-saved-continuation-marks-and 'k1 'v1)))) - (make-immutable-hash - (list (cons 'k1 'v1) - (cons 'k2 'v2))))) + "Preserve (beta)" + (check-equal? + (call-with-web-prompt + (lambda () + (with-continuation-mark the-save-cm-key + (make-immutable-hash (list (cons 'k2 'v2))) + + (call-with-immediate-continuation-mark + the-save-cm-key + (lambda (old-cms) + (with-continuation-mark the-save-cm-key + (hash-set old-cms 'k1 'v1) + (continuation-mark-set->list + (current-continuation-marks web-prompt) + the-save-cm-key))) + (make-immutable-hash empty))))) + (list (make-immutable-hash + (list (cons 'k1 'v1) + (cons 'k2 'v2)))))) + + #;(test-case + "Preserve" + (check-equal? + (call-with-web-prompt + (lambda () + (with-continuation-mark the-save-cm-key + (make-immutable-hash (list (cons 'k2 'v2))) + (with-current-saved-continuation-marks-and + 'k1 'v1 + (lambda () + (continuation-mark-set->list + (current-continuation-marks web-prompt) + the-save-cm-key)))))) + (list (make-immutable-hash + (list (cons 'k1 'v1) + (cons 'k2 'v2)))))) (test-case - "Update" - (check-equal? (call-with-web-prompt - (lambda () - (with-continuation-mark the-save-cm-key - (make-immutable-hash (list (cons 'k2 'v2) (cons 'k1 'v3))) - (current-saved-continuation-marks-and 'k1 'v1)))) - (make-immutable-hash - (list (cons 'k1 'v1) - (cons 'k2 'v2))))) + "Update (beta)" + (check-equal? + (call-with-web-prompt + (lambda () + (with-continuation-mark the-save-cm-key + (make-immutable-hash (list (cons 'k2 'v2) (cons 'k1 'v3))) + + (call-with-immediate-continuation-mark + the-save-cm-key + (lambda (old-cms) + (with-continuation-mark the-save-cm-key + (hash-set old-cms 'k1 'v1) + (continuation-mark-set->list + (current-continuation-marks web-prompt) + the-save-cm-key))) + (make-immutable-hash empty))))) + (list (make-immutable-hash + (list (cons 'k1 'v1) + (cons 'k2 'v2)))))) + + #;(test-case + "Update" + (check-equal? + (call-with-web-prompt + (lambda () + (with-continuation-mark the-save-cm-key + (make-immutable-hash (list (cons 'k2 'v2) (cons 'k1 'v3))) + (with-current-saved-continuation-marks-and + 'k1 'v1 + (lambda () + (continuation-mark-set->list + (current-continuation-marks web-prompt) + the-save-cm-key)))))) + (list (make-immutable-hash + (list (cons 'k1 'v1) + (cons 'k2 'v2)))))) (test-case - "Double" - (check-equal? (call-with-web-prompt - (lambda () - (with-continuation-mark the-save-cm-key - (make-immutable-hash (list (cons 'k3 'v1) (cons 'k4 'v0))) - ((lambda (x) x) - (with-continuation-mark the-save-cm-key - (make-immutable-hash (list (cons 'k2 'v2) (cons 'k1 'v3))) - (current-saved-continuation-marks-and 'k1 'v1)))))) - (make-immutable-hash - (list (cons 'k1 'v1) - (cons 'k2 'v2)))))) + "Double (beta)" + (check-equal? + (call-with-web-prompt + (lambda () + (with-continuation-mark the-save-cm-key + (make-immutable-hash (list (cons 'k3 'v1) (cons 'k4 'v2))) + ((lambda (x) x) + (with-continuation-mark the-save-cm-key + (make-immutable-hash (list (cons 'k2 'v2) (cons 'k1 'v3))) + + (call-with-immediate-continuation-mark + the-save-cm-key + (lambda (old-cms) + (with-continuation-mark the-save-cm-key + (hash-set old-cms 'k1 'v1) + (continuation-mark-set->list + (current-continuation-marks web-prompt) + the-save-cm-key))) + (make-immutable-hash empty))))))) + (list (make-immutable-hash + (list (cons 'k1 'v1) + (cons 'k2 'v2))) + (make-immutable-hash + (list (cons 'k3 'v1) + (cons 'k4 'v2)))))) + + #;(test-case + "Double" + (check-equal? + (call-with-web-prompt + (lambda () + (with-continuation-mark the-save-cm-key + (make-immutable-hash (list (cons 'k3 'v1) (cons 'k4 'v2))) + ((lambda (x) x) + (with-continuation-mark the-save-cm-key + (make-immutable-hash (list (cons 'k2 'v2) (cons 'k1 'v3))) + (with-current-saved-continuation-marks-and + 'k1 'v1 + (lambda () + (continuation-mark-set->list + (current-continuation-marks web-prompt) + the-save-cm-key)))))))) + (list (make-immutable-hash + (list (cons 'k1 'v1) + (cons 'k2 'v2))) + (make-immutable-hash + (list (cons 'k3 'v1) + (cons 'k4 'v2))))))) (test-suite "activation-record-list" @@ -169,7 +264,7 @@ (continuation-mark-set->list* (current-continuation-marks) (list 1 3 5 7))) - #f)) + #f)) (list 42))))) (list (vector #f #f #f 8) (vector #f #f 6 #f) diff --git a/collects/web-server/lang/abort-resume.ss b/collects/web-server/lang/abort-resume.ss index 7acf796856..ff57792b51 100644 --- a/collects/web-server/lang/abort-resume.ss +++ b/collects/web-server/lang/abort-resume.ss @@ -12,13 +12,14 @@ (define safe-call? (make-mark-key)) (define web-prompt (make-continuation-prompt-tag 'web)) -(define (current-saved-continuation-marks-and key val) - (define c - (continuation-mark-set->list (current-continuation-marks web-prompt) - the-save-cm-key)) - (if (empty? c) - (make-immutable-hash (list (cons key val))) - (hash-set (first c) key val))) +(define (with-current-saved-continuation-marks-and key val thnk) + (call-with-immediate-continuation-mark + the-save-cm-key + (lambda (old-cms) + (with-continuation-mark the-save-cm-key + (hash-set old-cms key val) + (thnk))) + (make-immutable-hash empty))) ;; current-continuation-as-list: -> (listof value) ;; check the safety marks and return the list of marks representing the continuation @@ -173,7 +174,7 @@ [safe-call? mark-key?] [the-undef undef?] [activation-record-list (-> saved-context?)] - [current-saved-continuation-marks-and (any/c any/c . -> . cms?)] + [with-current-saved-continuation-marks-and (any/c any/c (-> any/c) . -> . any/c)] [kont-append-fun (kont? procedure? . -> . kont?)] ;; "CLIENT" INTERFACE diff --git a/collects/web-server/lang/elim-callcc.ss b/collects/web-server/lang/elim-callcc.ss index dac6d1b22c..c0de68006c 100644 --- a/collects/web-server/lang/elim-callcc.ss +++ b/collects/web-server/lang/elim-callcc.ss @@ -74,10 +74,8 @@ (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)))))] + (#%plain-app with-current-saved-continuation-marks-and #,ke-prime #,me-prime + (#%plain-lambda () #,be-prime))))))] [(#%plain-app call/cc w) (let-values ([(cm ref-to-cm) (generate-formal 'current-marks stx)] [(x ref-to-x) (generate-formal 'x stx)])