immediate marking
svn: r13299
This commit is contained in:
Jay McCarthy
parent
d518d5a32c
commit
254f924ebb
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user