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

New tests

Browse Source 
svn: r11421
This commit is contained in:
Jay McCarthy 2008-08-25 16:48:14 +00:00
parent 0c56691440
commit bc7747f4cf
3 changed files with 227 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -35,21 +35,20 @@
(define web-prompt (make-continuation-prompt-tag 'web))
(define (current-saved-continuation-marks-and key val)
(reverse
(list* (cons key val)
(filter (lambda (k*v) (not (equal? key (car k*v))))
(let-values ([(current)
(continuation-mark-set->list (current-continuation-marks web-prompt)
the-save-cm-key)])
(if (empty? current)
empty
(first current)))))))
(list* (cons key val)
(filter (lambda (k*v) (not (equal? key (car k*v))))
(let-values ([(current)
(continuation-mark-set->list (current-continuation-marks web-prompt)
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 web-prompt)]
[sl (reverse (continuation-mark-set->list cm safe-call?))])
[sl (continuation-mark-set->list cm safe-call?)])
(if (andmap (lambda (x)
(if (pair? x)
(car x)
@ -66,6 +65,14 @@
#;(printf "abort ~S~n" thunk)
(abort-current-continuation web-prompt thunk))
;; with-continuation-marks : (listof (cons any1 any2)) (-> any3) -> any3
(define (with-continuation-marks cms thnk)
(match cms
[(list) (thnk)]
[(list-rest (cons cm-key cm-val) cms)
(with-continuation-mark cm-key cm-val
(with-continuation-marks cms thnk))]))
;; resume: (listof (value -> value)) value -> value
;; resume a computation given a value and list of frame procedures
(define (resume frames val)
@ -80,18 +87,11 @@
[(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)])]))
[(vector #f cms)
(with-continuation-mark the-save-cm-key cms
(with-continuation-marks cms (lambda () (resume fs val))))]
[(vector f cms)
(resume (list* (vector f #f) (vector #f cms) fs) val)])]))
;; rebuild-cms : frames (-> value) -> value
(define (rebuild-cms frames thunk)
@ -103,13 +103,8 @@
(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)))])]))
[(vector f cms)
(with-continuation-marks cms (lambda () (rebuild-cms fs thunk)))])]))
(define (abort/cc thunk)
(call-with-continuation-prompt

201
collects/web-server/tests/lang/abort-resume-test.ss Normal file
View File

@ -0,0 +1,201 @@
#lang scheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(planet "util.ss" ("schematics" "schemeunit.plt" 2))
web-server/lang/abort-resume)
(provide abort-resume-tests)
(define abort-resume-tests
(test-suite
"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))))
(test-case
"Easy"
(check-equal? (abort/cc
(lambda () (current-saved-continuation-marks-and 'k1 'v1)))
(list (cons 'k1 'v1))))
(test-case
"Preserve"
(check-equal? (abort/cc
(lambda ()
(with-continuation-mark the-save-cm-key (list (cons 'k2 'v2))
(current-saved-continuation-marks-and 'k1 'v1))))
(list (cons 'k1 'v1)
(cons 'k2 'v2))))
(test-case
"Update"
(check-equal? (abort/cc
(lambda ()
(with-continuation-mark the-save-cm-key (list (cons 'k2 'v2) (cons 'k1 'v3))
(current-saved-continuation-marks-and 'k1 'v1))))
(list (cons 'k1 'v1)
(cons 'k2 'v2))))
(test-case
"Double"
(check-equal? (abort/cc
(lambda ()
(with-continuation-mark the-save-cm-key (list (cons 'k3 'v1) (cons 'k4 'v0))
((lambda (x) x)
(with-continuation-mark the-save-cm-key (list (cons 'k2 'v2) (cons 'k1 'v3))
(current-saved-continuation-marks-and 'k1 'v1))))))
(list (cons 'k1 'v1)
(cons 'k2 'v2)))))
(test-suite
"activation-record-list"
(test-case
"Not in prompt"
(check-exn exn? (lambda () (activation-record-list))))
(test-case
"Easy"
(check-equal? (abort/cc
(lambda () (activation-record-list)))
empty))
(test-case
"Single"
(check-equal? (abort/cc
(lambda ()
(let/ec esc
('f1 (with-continuation-mark the-cont-key 'f1
(esc (activation-record-list)))))))
(list (vector 'f1 #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
(esc (activation-record-list)))))))))
; Opposite the order of c-c-m
(list (vector 'f1 #f)
(vector 'f2 #f))))
(test-case
"Unsafe"
(check-exn
exn?
(lambda ()
(abort/cc
(lambda ()
(with-continuation-mark safe-call? #f
(activation-record-list))))))))
(test-suite
"abort"
(test-case
"Not in prompt"
(check-exn exn? (lambda () (abort (lambda () 42)))))
(test-case
"Simple"
(check-equal? (abort/cc
(lambda ()
(abort (lambda () 42))))
42)))
(test-suite
"resume"
(test-case
"Simple"
(check-equal? (resume empty (list 42))
42))
(test-case
"Empty frame"
(check-exn exn? (lambda () (resume (list (vector #f #f)) (list 42)))))
(test-case
"Kont"
(let ([f (lambda (x) (* x x))])
(check-equal? (resume (list (vector f #f)) (list 42))
(f 42))))
(test-case
"Kont 2"
(let ([f (lambda (x) (* x x))]
[g (lambda (x) (+ x x))])
(check-equal? (resume (list (vector f #f) (vector g #f)) (list 42))
(f (g 42)))))
(test-case
"Cont-key"
(let ([f (lambda (x) (* x x))]
[g (lambda (x) (+ x x))]
[esc-b (box #f)]
[capture (lambda _ (activation-record-list))])
(check-equal? (abort/cc
(lambda ()
(let/ec esc
(set-box! esc-b esc)
(resume (list (vector f #f) (vector g #f)
(vector esc #f) (vector capture #f))
(list 42)))))
(list (vector f #f) (vector g #f)
(vector (unbox esc-b) #f)))))
(test-case
"marks"
(let ([f (lambda (x) (* x x))]
[g (lambda (x) (+ x x))])
(check-equal? (abort/cc
(lambda ()
(let/ec esc
(resume (list (vector f (list (cons 3 4) (cons 1 2)))
(vector g (list (cons 5 6)))
(vector esc (list (cons 7 8)))
(vector (lambda _
(continuation-mark-set->list*
(current-continuation-marks)
(list 1 3 5 7)))
#f))
(list 42)))))
(list (vector #f #f #f 8)
(vector #f #f 6 #f)
(vector 2 4 #f #f)))))
(test-case
"cm-key"
(let ([f (lambda (x) (* x x))]
[g (lambda (x) (+ x x))]
[esc-b (box #f)]
[capture (lambda _ (activation-record-list))])
(check-equal? (abort/cc
(lambda ()
(let/ec esc
(set-box! esc-b esc)
(resume (list (vector f (list (cons 3 4) (cons 1 2)))
(vector g (list (cons 5 6)))
(vector esc (list (cons 7 8)))
(vector capture #f))
(list 42)))))
(list (vector f (list (cons 3 4) (cons 1 2)))
(vector g (list (cons 5 6)))
(vector (unbox esc-b) (list (cons 7 8))))))))
; XXX test kont
; XXX test kont-append-fun
; XXX test send/suspend
; XXX test dispatch-start
; XXX test dispatch
))

2
collects/web-server/tests/lang/all-lang-tests.ss
View File

@ -1,5 +1,6 @@
#lang scheme/base
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
"abort-resume-test.ss"
"anormal-test.ss"
"defun-test.ss"
"file-box-test.ss"
@ -11,6 +12,7 @@
(define all-lang-tests
(test-suite
"Web Language"
abort-resume-tests
anormal-tests
defun-tests
file-box-tests