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

test suite for control library

Browse Source 
svn: r4578
This commit is contained in:
Matthew Flatt 2006-10-13 06:24:20 +00:00
parent 949beaa30f
commit 5984c169d3
1 changed files with 273 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

273
collects/tests/mzscheme/control.ss Normal file
View File

@ -0,0 +1,273 @@
;; Examples from Oleg Kiselyov's:
;; Generic implementation of all four delimited control operators
;; shift/reset, prompt/control, shift0/reset0 and prompt0/control0
;; aka. -F- through +F+
;; $Id: delim-control-n.scm 815 2005-09-05 23:02:12Z oleg $
;; Plus examples from some papers
(load-relative "loadtest.ss")
(Section 'control)
(require (lib "control.ss")
(only (lib "etc.ss") rec))
;-----------------------------------------------------------------------
(define-syntax ctest
(syntax-rules ()
[(_ expr expect)
(test expect 'expr expr)]))
;-----------------------------------------------------------------------
; Shift tests
(ctest (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3)))))))
117)
(ctest (* 10 (reset (* 2 (shift g (reset
(* 5 (shift f (+ (f 1) 1))))))))
60)
(ctest (let ((f (lambda (x) (shift k (k (k x))))))
(+ 1 (reset (+ 10 (f 100)))))
121)
(ctest (reset
(let ((x (shift f (cons 'a (f '())))))
(shift g x)))
'(a))
(define (shift* p) (shift f (p f)))
(ctest (reset (let ((x 'abcde)) (eq? x ((shift* shift*) x))))
#t)
(define traverse
(lambda (xs)
(letrec ((visit
(lambda (xs)
(if (null? xs)
'()
(visit (shift k
(cons (car xs)
(k (cdr xs)))))))))
(reset
(visit xs)))))
(ctest (traverse '(1 2 3 4 5))
'(1 2 3 4 5))
;-----------------------------------------------------------------------
; Control tests
; Example from Sitaram, Felleisen
(define (abort v) (control k v))
(ctest (let ((g (prompt (* 2 (control k k)))))
(* 3 (prompt (* 5 (abort (g 7))))))
42)
; Olivier Danvy's puzzle
(define traverse
(lambda (xs)
(letrec ((visit
(lambda (xs)
(if (null? xs)
'()
(visit (control k
(cons (car xs)
(k (cdr xs)))))))))
(prompt
(visit xs)))))
(ctest (traverse '(1 2 3 4 5))
'(5 4 3 2 1))
(ctest (+ 10 (prompt (+ 2 (control k (+ 100 (k (k 3)))))))
117)
(ctest (prompt (let ((x (control f (cons 'a (f '()))))) (control g x)))
'())
(ctest (prompt ((lambda (x) (control l 2))
(control l (+ 1 (l 0)))))
2)
(ctest (prompt (control f (cons 'a (f '()))))
'(a))
(ctest (prompt (let ((x (control f (cons 'a (f '())))))
(control g (g x))))
'(a))
(define (control* f) (control k (f k)))
(ctest (prompt (let ((x 'abcde)) (eq? x ((control* control*) x))))
#t)
;------------------------------------------------------------------------
; shift0/control0 tests
(ctest (+ 10 (prompt0 (+ 2 (control k (+ 100 (k (k 3)))))))
117)
(ctest (prompt0 (prompt0
(let ((x (control f (cons 'a (f '())))))
(control g x))))
'())
(ctest (+ 10 (prompt0 (+ 2 (shift0 k (+ 100 (k (k 3)))))))
117)
(ctest (prompt0 (cons 'a (prompt0 (shift0 f (shift0 g '())))))
'())
(ctest (prompt (cons 'a (prompt (shift0 f (shift0 g '())))))
'(a))
;; ----------------------------------------
;; Examples from Dorai Sitaram's dissertation
(define make-fringe
(lambda (tree)
(lambda (any)
(let loop ([tree tree])
(cond
[(pair? tree)
(loop (car tree))
(loop (cdr tree))]
[(null? tree) '*]
[else (fcontrol tree)]))
(fcontrol '()))))
(define same-fringe?
(lambda (tree1 tree2)
(let loop ([fringe1 (make-fringe tree1)]
[fringe2 (make-fringe tree2)])
(% (fringe1 '*)
(lambda (leaf1 rest-of-fringe1)
(% (fringe2 '*)
(lambda (leaf2 rest-of-fringe2)
(cond
[(and (null? leaf1) (null? leaf2)) #t]
[(or (null? leaf1) (null? leaf2)) #f]
[(eqv? leaf1 leaf2) (loop rest-of-fringe1
rest-of-fringe2)]
[else #f]))))))))
(ctest (same-fringe? '(1 . (2 . (3 . 4)))
'(1 . ((2 . 3) . 4)))
#t)
(ctest (same-fringe? '(1 . (2 . (3 . 4)))
'(1 . ((2 . 5) . 4)))
#f)
(define all-prefixes
(lambda (l)
(letrec ([loop (lambda (l)
(if (null? l)
(fcontrol 'done)
(cons (car l)
(fcontrol (cdr l)))))])
(% (loop l)
(rec h
(lambda (r k)
(if (eq? r 'done)
'()
(cons (k '())
(% (k (loop r)) h)))))))))
(ctest (all-prefixes '(1 2 3 4))
'((1) (1 2) (1 2 3) (1 2 3 4)))
;; ------------------------------------------------------------
;; spawn
;; example from Queinnec & Serpete, POPL'91
(ctest (spawn (lambda (f)
(let ([v (f (lambda (c2)
(cons 2 (c2 3))))])
(cons (f (lambda (cl)
(cons 1 (cl 4))))
v))))
'(2 1 4 . 3))
(ctest (spawn (lambda (f)
(cons (f (lambda (cl)
(cons 1 (cl 4))))
(f (lambda (c2)
(cons 2 (c2 3)))))))
'(1 2 4 . 3))
;; ------------------------------------------------------------
;; splitter
;; example from Queinnec & Serpete, POPL'91
(define (visit tree fn)
(if (pair? tree)
(begin (visit (car tree) fn)
(visit (cdr tree) fn))
(fn tree)))
(define (make-tree-walker visit)
(lambda (tree)
(splitter
(lambda (exit grab)
(visit
tree
(lambda (leaf)
(grab
(lambda (c)
(exit (lambda ()
(cons
leaf
(lambda (v)
(splitter
(lambda (k j )
(set! grab j)
(set! exit k)
(c v)))))))))))))))
(define (compare-fringes walk trees)
(let ((end (list 'end)))
(define (end? leaf) (eq? leaf end))
(define (loop leafs)
(define (same-leaf? leaf)
(eq? (car leaf) (caar leafs)))
(or ; all trees are finished ?
(andmap end? leafs)
;; some trees are jinished ?
(if (ormap end? leafs)
#f
(and (andmap same-leaf?
(cdr leafs))
;; all leaves are equal !
(loop (map
(lambda (leaf)
((cdr leaf) end) )
leafs )) ) ) ) )
(loop (map walk trees)) ) )
(define (same-fringe trees)
(compare-fringes (make-tree-walker visit)
trees))
(ctest (same-fringe (list '(1 . (2 . (3 . 4)))
'(1 . ((2 . 3) . 4))))
#t)
(ctest (same-fringe (list '(1 . (2 . (3 . 4)))
'(1 . ((2 . 5) . 4))))
#f)
;; ----------------------------------------
;; cupto
(ctest (let ([p (new-prompt)])
(set p
(+ 1
(cupto p k (+ 3 (k 2) (k 5))))))
12)
;; ----------------------------------------
(report-errs)