suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

immediate marking

Browse Source 
svn: r13299
This commit is contained in:
Jay McCarthy 2009-01-28 15:30:36 +00:00
parent d518d5a32c
commit 254f924ebb
3 changed files with 144 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

171
collects/tests/web-server/lang/abort-resume-test.ss
View File

@ -2,6 +2,7 @@
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(planet "util.ss" ("schematics" "schemeunit.plt" 2)) (planet "util.ss" ("schematics" "schemeunit.plt" 2))
web-server/lang/abort-resume) web-server/lang/abort-resume)
(require/expose web-server/lang/abort-resume (web-prompt))
(provide abort-resume-tests) (provide abort-resume-tests)
(define abort-resume-tests (define abort-resume-tests
@ -9,52 +10,146 @@
"Abort/Resume" "Abort/Resume"
(test-suite (test-suite
"current-saved-continuation-marks-and" "with-current-saved-continuation-marks-and"
(test-case
"Not in prompt"
(check-exn exn? (lambda () (current-saved-continuation-marks-and 'k1 'v1))))
(test-case (test-case
"Easy" "Easy"
(check-equal? (call-with-web-prompt (check-equal?
(lambda () (current-saved-continuation-marks-and 'k1 'v1))) (call-with-web-prompt
(make-immutable-hash (list (cons 'k1 'v1))))) (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 (test-case
"Preserve" "Preserve (beta)"
(check-equal? (call-with-web-prompt (check-equal?
(lambda () (call-with-web-prompt
(with-continuation-mark the-save-cm-key (make-immutable-hash (list (cons 'k2 'v2))) (lambda ()
(current-saved-continuation-marks-and 'k1 'v1)))) (with-continuation-mark the-save-cm-key
(make-immutable-hash (make-immutable-hash (list (cons 'k2 'v2)))
(list (cons 'k1 'v1)
(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 (test-case
"Update" "Update (beta)"
(check-equal? (call-with-web-prompt (check-equal?
(lambda () (call-with-web-prompt
(with-continuation-mark the-save-cm-key (lambda ()
(make-immutable-hash (list (cons 'k2 'v2) (cons 'k1 'v3))) (with-continuation-mark the-save-cm-key
(current-saved-continuation-marks-and 'k1 'v1)))) (make-immutable-hash (list (cons 'k2 'v2) (cons 'k1 'v3)))
(make-immutable-hash
(list (cons 'k1 'v1) (call-with-immediate-continuation-mark
(cons 'k2 'v2))))) 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 (test-case
"Double" "Double (beta)"
(check-equal? (call-with-web-prompt (check-equal?
(lambda () (call-with-web-prompt
(with-continuation-mark the-save-cm-key (lambda ()
(make-immutable-hash (list (cons 'k3 'v1) (cons 'k4 'v0))) (with-continuation-mark the-save-cm-key
((lambda (x) x) (make-immutable-hash (list (cons 'k3 'v1) (cons 'k4 'v2)))
(with-continuation-mark the-save-cm-key ((lambda (x) x)
(make-immutable-hash (list (cons 'k2 'v2) (cons 'k1 'v3))) (with-continuation-mark the-save-cm-key
(current-saved-continuation-marks-and 'k1 'v1)))))) (make-immutable-hash (list (cons 'k2 'v2) (cons 'k1 'v3)))
(make-immutable-hash
(list (cons 'k1 'v1) (call-with-immediate-continuation-mark
(cons 'k2 'v2)))))) 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 (test-suite
"activation-record-list" "activation-record-list"
@ -169,7 +264,7 @@
(continuation-mark-set->list* (continuation-mark-set->list*
(current-continuation-marks) (current-continuation-marks)
(list 1 3 5 7))) (list 1 3 5 7)))
#f)) #f))
(list 42))))) (list 42)))))
(list (vector #f #f #f 8) (list (vector #f #f #f 8)
(vector #f #f 6 #f) (vector #f #f 6 #f)

17
collects/web-server/lang/abort-resume.ss
View File

@ -12,13 +12,14 @@
(define safe-call? (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 (with-current-saved-continuation-marks-and key val thnk)
(define c (call-with-immediate-continuation-mark
(continuation-mark-set->list (current-continuation-marks web-prompt) the-save-cm-key
the-save-cm-key)) (lambda (old-cms)
(if (empty? c) (with-continuation-mark the-save-cm-key
(make-immutable-hash (list (cons key val))) (hash-set old-cms key val)
(hash-set (first c) key val))) (thnk)))
(make-immutable-hash empty)))
;; current-continuation-as-list: -> (listof value) ;; current-continuation-as-list: -> (listof value)
;; check the safety marks and return the list of marks representing the continuation ;; check the safety marks and return the list of marks representing the continuation
@ -173,7 +174,7 @@
[safe-call? mark-key?] [safe-call? mark-key?]
[the-undef undef?] [the-undef undef?]
[activation-record-list (-> saved-context?)] [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?)] [kont-append-fun (kont? procedure? . -> . kont?)]
;; "CLIENT" INTERFACE ;; "CLIENT" INTERFACE

6
collects/web-server/lang/elim-callcc.ss
View File

@ -74,10 +74,8 @@
(markit (markit
(quasisyntax/loc stx (quasisyntax/loc stx
(with-continuation-mark #,ke-prime #,me-prime (with-continuation-mark #,ke-prime #,me-prime
(with-continuation-mark (#%plain-app with-current-saved-continuation-marks-and #,ke-prime #,me-prime
the-save-cm-key (#%plain-lambda () #,be-prime))))))]
(#%plain-app current-saved-continuation-marks-and #,ke-prime #,me-prime)
#,be-prime)))))]
[(#%plain-app call/cc w) [(#%plain-app call/cc w)
(let-values ([(cm ref-to-cm) (generate-formal 'current-marks stx)] (let-values ([(cm ref-to-cm) (generate-formal 'current-marks stx)]
[(x ref-to-x) (generate-formal 'x stx)]) [(x ref-to-x) (generate-formal 'x stx)])