haskeem-0.7.9: deltest.scm
; (load "delcont.scm")
(defmacro (sandbox . expr)
(let ((err (gensym)))
`(guard
(,err ((begin (write-string "caught exception '")
(display ,err)
(write-string "'\n")
#t)))
,@expr)))
; for mzscheme, replace the above definition of sandbox with
; (define (sandbox . expr) #t)
; it won't catch exceptions, but then mzscheme doesn't produce
; any, except for the intentional syntax error at the end
(write-string "all answers are checked against mzscheme\n")
(write-string "examples from community.schemewiki.org\n")
(write-string "should be 6\t\t")
(display (+ 1 (reset (+ 2 3))))
(newline)
(write-string "should be (1 2)\t\t")
(display (cons 1 (reset (cons 2 '()))))
(newline)
(write-string "should be 4\t\t")
(display (+ 1 (reset (+ 2 (shift k 3)))))
(newline)
(write-string "should be (1 3)\t\t")
(display (cons 1 (reset (cons 2 (shift k (cons 3 '()))))))
(newline)
(write-string "should be 10\t\t")
(display (+ 1 (reset (+ 2 (shift k (+ 3 (k 4)))))))
(newline)
(write-string "should be 14\t\t")
(display (+ 1 (reset (+ 2 (shift k (+ 3 (k 5) (k 1)))))))
(newline)
(write-string "should be (1 3 2 4)\t")
(display (cons 1 (reset (cons 2 (shift k (cons 3 (k (cons 4 '()))))))))
(newline)
(write-string "should be (1 3 2 2 4)\t")
(display (cons 1 (reset (cons 2 (shift k (cons 3 (k (k (cons 4 '())))))))))
(newline)
(write-string "multiple shifts\n")
(write-string "should be 2\t\t")
(reset (display (begin (shift k1 (k1 1)) (shift k2 (k2 2)))))
(newline)
; haskeem fails this -- restart issue
(write-string "should be 12\t\t")
(reset (begin (display (shift k1 (k1 1))) (display (shift k2 (k2 2)))))
(newline)
(write-string "should be 12\t\t")
(reset (display (shift k1 (k1 1))) (display (shift k2 (k2 2))))
(newline)
(write-string "should be 134234\t")
(reset0 (begin (shift0 k1 (begin (k1 (display 1)) (k1 (display 2))))
(shift0 k2 (begin (k2 (display 3)) (k2 (display 4))))))
(newline)
(write-string "should be 134234\t")
(reset0 (begin (shift0 k1 (k1 (display 1)) (k1 (display 2)))
(shift0 k2 (k2 (display 3)) (k2 (display 4)))))
(newline)
(write-string "should be 134234\t")
(reset0 (shift0 k1 (k1 (display 1)) (k1 (display 2)))
(shift0 k2 (k2 (display 3)) (k2 (display 4))))
(newline)
(write-string "should be 13564562356456\n\t ")
(reset0 (begin (shift0 k1 (begin (k1 (display 1)) (k1 (display 2))))
(shift0 k2 (begin (k2 (display 3)) (k2 (display 4))))
(shift0 k3 (begin (k3 (display 5)) (k3 (display 6))))))
(write-string "\n\t ")
(reset0 (begin (shift0 k1 (k1 (display 1)) (k1 (display 2)))
(shift0 k2 (k2 (display 3)) (k2 (display 4)))
(shift0 k3 (k3 (display 5)) (k3 (display 6)))))
(write-string "\n\t ")
(reset0 (shift0 k1 (k1 (display 1)) (k1 (display 2)))
(shift0 k2 (k2 (display 3)) (k2 (display 4)))
(shift0 k3 (k3 (display 5)) (k3 (display 6))))
(newline)
(write-string "should be 57\t\t")
(display (+ 1 (reset (+ 2 (shift k1 (+ 3
(k1 5)
(k1 1)
(reset (* 10 (shift k2 (+ 3 (k2 4)))))
))))))
(newline)
(write-string "should be 59\t\t")
(display (+ 1 (reset (+ 2 (shift k1 (+ 3
(k1 5)
(k1 1)
(reset (* 10 (shift k2 (+ (k1 3)
(k2 4)))))
))))))
(newline)
; haskeem fails the following nine -- restart issue
(write-string "should be 1 3 2\t\t")
(reset (begin (write-string "1 ")
(shift c (begin (c 'ignore)
(write-string "2 ")))
(write-string "3 ")))
(newline)
(write-string "should be 1 3 2\t\t")
(reset (begin (write-string "1 ")
(shift c (c 'ignore) (write-string "2 "))
(write-string "3 ")))
(newline)
(write-string "should be 1 3 2\t\t")
(reset (write-string "1 ")
(shift c (c 'ignore) (write-string "2 "))
(write-string "3 "))
(newline)
(write-string "should be 1 2 3\t\t")
(reset (begin (write-string "1 ")
(shift c (begin (write-string "2 ")
(c 'ignore)))
(write-string "3 ")))
(newline)
(write-string "should be 1 2 3\t\t")
(reset (begin (write-string "1 ")
(shift c (write-string "2 ") (c 'ignore))
(write-string "3 ")))
(newline)
(write-string "should be 1 2 3\t\t")
(reset (write-string "1 ")
(shift c (write-string "2 ") (c 'ignore))
(write-string "3 "))
(newline)
(write-string "should be 1 3 2 3\t")
(reset (begin (write-string "1 ")
(shift c (begin (c 'ignore)
(write-string "2 ")
(c 'ignore)))
(write-string "3 ")))
(newline)
(write-string "should be 1 3 2 3\t")
(reset (begin (write-string "1 ")
(shift c (c 'ignore) (write-string "2 ") (c 'ignore))
(write-string "3 ")))
(newline)
(write-string "should be 1 3 2 3\t")
(reset (write-string "1 ")
(shift c (c 'ignore) (write-string "2 ") (c 'ignore))
(write-string "3 "))
(newline)
(write-string "from Shan, \"Shift to Control\"\n")
(write-string "should be (a)\t\t")
(display (reset (cons 'a (reset (shift f (shift g '()))))))
(newline)
(write-string "should be ()\t\t")
(display (reset0 (cons 'a (reset0 (shift0 f (shift0 g '()))))))
(newline)
(write-string "should be (a)\t\t")
(display (reset (let ((y (shift f (cons 'a (f '()))))) (shift g y))))
(newline)
(write-string "should be ()\t\t")
(display (prompt (let ((y (control f (cons 'a (f '()))))) (control g y))))
(newline)
; Shan sez this is an infinite loop... Kiselyov turns this into a printing
; loop by adding (display) somewhere, have to see if I can replicate that.
; I dunno if the name has to be 'f' in both control parts
;(prompt (begin (control f (begin (f 0) (f 0)))
; (control f (begin (f 0) (f 0)))))
;;;(write-string "should be 132342344234442344442344444234444442344...\n\t ")
;;; with reset2 it /is/ an infinite loop, just not the desired one...
;;; it produces 1313131313... instead
;;; I think this is actually the same partially-evaluated-thunk issue
;;; as with the other tests which are failing
;;;(prompt (begin (control f (begin (f (display 1)) (f (display 2))))
;;; (control f (begin (f (display 3)) (f (display 4))))))
;;;(newline)
(write-string "should be (a)\t\t")
(display (reset (let ((y (shift f (cons 'a (f '()))))) (shift g y))))
(newline)
(write-string "should be (a)\t\t")
(display (reset0 (let ((y (shift0 f (cons 'a (f '()))))) (shift0 g y))))
(newline)
(write-string "should be ()\t\t")
(display (prompt (let ((y (control f (cons 'a (f '()))))) (control g y))))
(newline)
(write-string "should be ()\t\t")
(display
(reset (prompt0 (let ((y (control0 f (cons 'a (f '()))))) (control0 g y)))))
(newline)
(write-string "should be (a b)\t\t")
(display
(reset
(reset (cons 'a (reset
(let ((y (shift f (shift g (cons 'b (f '()))))))
(shift h y)))))))
(newline)
(write-string "should be (a)\t\t")
(display
(prompt
(prompt (cons 'a (prompt
(let ((y (control f (control g (cons 'b (f '()))))))
(control h y)))))))
(newline)
(write-string "should be (b)\t\t")
(display
(reset0
(reset0 (cons 'a (reset0
(let ((y (shift0 f (shift0 g (cons 'b (f '()))))))
(shift0 h y)))))))
(newline)
; haskeem fails this -- UNKNOWN ISSUE! TODO: investigate!
(write-string "should be ()\t\t")
(display
(prompt0
(prompt0 (cons 'a (prompt0
(let ((y (control0 f (control0 g (cons 'b (f '()))))))
(control0 h y)))))))
(newline)
(write-string "two-armed tests\n")
(write-string "test 1: non-trivial shift only in false arm of if\n")
(define (doit1 flag)
(if flag
(write-string "should be (1 3)\t\t")
(write-string "should be (1 4 2 5)\t"))
(display
(cons 1 (reset (cons 2 (if flag
(shift k1 (cons 3 '()))
(shift k2 (cons 4 (k2 (cons 5 '())))))))))
(newline))
(doit1 #f)
(doit1 #t)
(write-string "test 2: reverse of previous\n")
(define (doit2 flag)
(if flag
(write-string "should be (1 4 2 5)\t")
(write-string "should be (1 3)\t\t"))
(display
(cons 1 (reset (cons 2 (if flag
(shift k2 (cons 4 (k2 (cons 5 '()))))
(shift k1 (cons 3 '())))))))
(newline))
(doit2 #f)
(doit2 #t)
(write-string "test 3: wrong? expansion of test 1\n")
(define (doit3 flag)
(write-string "should be (1 4 3)\t") ; independent of flag
(display
(cons 1
(let ((k2 (lambda (v2)
(let ((k1 (lambda (v1)
(reset (cons 2 (if flag v1 v2))))))
(cons 3 '()))
)))
(reset (cons 4 (k2 (cons 5 '())))))))
(newline))
(doit3 #f)
(doit3 #t)
(write-string "test 4: expansion of test 2\n")
(define (doit4 flag)
(if flag
(write-string "should be (1 4 2 3)\t")
(write-string "should be (1 4 2 5)\t"))
(display
(cons 1
(let ((k2 (lambda (v2)
(reset (cons 2 (if flag (cons 3 '()) v2))))))
(reset (cons 4 (k2 (cons 5 '())))))
))
(newline))
(doit4 #f)
(doit4 #t)
(write-string "test 5: modified version, with (shift) in both arms of (if)\n")
(define (doit5 flag)
(if flag
(write-string "should be (1 3 2 4)\t")
(write-string "should be (1 5 2 6)\t"))
(display
(cons 1
(reset (cons 2 (if flag
(shift k1 (cons 3 (k1 (cons 4 '()))))
(shift k2 (cons 5 (k2 (cons 6 '())))))))))
(newline))
(doit5 #f)
(doit5 #t)
; This one seems to be right either way... had to lift the (if flag)
; outside the (reset), which seems both intuitive and counter-intuitive.
; :-/
(write-string
"test 6: modified version of test 5, with (if) lifted out of (reset)\n")
(define (doit6 flag)
(if flag
(write-string "should be (1 3 2 4)\t")
(write-string "should be (1 5 2 6)\t"))
(display
(cons 1
(if flag
(reset (cons 2 (shift k1 (cons 3 (k1 (cons 4 '()))))))
(reset (cons 2 (shift k2 (cons 5 (k2 (cons 6 '())))))))))
(newline))
(doit6 #f)
(doit6 #t)
(write-string "examples from Queinnec, augmented to test all versions\n")
(write-string "prompt/control examples\n")
(write-string "should be 3\t\t")
(display (prompt (* 2 (control f 3))))
(newline)
(write-string "should be 30\t\t")
(display (prompt (* 2 (control f (* 5 (f 3))))))
(newline)
(write-string "should be 12\t\t")
(display (prompt (* 2 (control f (f (f 3))))))
(newline)
(write-string "should be 6\t\t")
(display ((prompt (* 2 (control f f))) 3))
(newline)
(write-string "should be 35\t\t")
(display (prompt (* 5
(prompt (* 2
(control f2 (* 3 (control f3 7))))))))
(newline)
; haskeem quasi-fails this: because it's a (lambda () ...), it escapes,
; and so at the end there's an uncaught exception which however carries
; along the correct value as its payload. So I think haskeem would handle
; this correctly if there were an implicit top-level catcher
(write-string "should be 7\t\t")
(sandbox
(display (prompt (* 5 (
(prompt (* 2
(control f2 (lambda ()
(* 3 (control f3 7))))))))))
(newline))
(write-string "should be 21\t\t")
(display (prompt (* 5
((lambda (x) (control f1 x))
(* 3 (control f2 (* 2 (f2 7))))))))
(newline)
(write-string "prompt0/control0 examples\n")
(write-string "should be 3\t\t")
(display (prompt0 (* 2 (control0 f 3))))
(newline)
(write-string "should be 30\t\t")
(display (prompt0 (* 2 (control0 f (* 5 (f 3))))))
(newline)
(write-string "should be 12\t\t")
(display (prompt0 (* 2 (control0 f (f (f 3))))))
(newline)
(write-string "should be 6\t\t")
(display ((prompt0 (* 2 (control0 f f))) 3))
(newline)
(write-string "should be 7\t\t")
(display (prompt0 (* 5
(prompt0 (* 2
(control0 f2 (* 3 (control0 f3 7))))))))
(newline)
(write-string "should be 7\t\t")
(sandbox
(display (prompt0 (* 5 (
(prompt0 (* 2
(control0 f2 (lambda ()
(* 3 (control0 f3 7))))))))))
(newline))
; There's something odd with this test: in mzscheme, it prints the
; result 21, then the whole rest of the test vanishes; apparently
; enough of the surrounding context is sucked up that the rest of the
; world just vanishes. If I surround this with a (reset ...), the
; test continues, but this doesn't print anything. Hmmm!
(write-string "should be 21\t\t")
(sandbox
(display (prompt0 (* 5
((lambda (x) (control0 f1 x))
(* 3 (control0 f2 (* 2 (f2 7))))))))
(newline))
(write-string "reset/shift examples\n")
(write-string "should be 3\t\t")
(display (reset (* 2 (shift f 3))))
(newline)
(write-string "should be 30\t\t")
(display (reset (* 2 (shift f (* 5 (f 3))))))
(newline)
(write-string "should be 12\t\t")
(display (reset (* 2 (shift f (f (f 3))))))
(newline)
(write-string "should be 6\t\t")
(display ((reset (* 2 (shift f f))) 3))
(newline)
(write-string "should be 35\t\t")
(display (reset (* 5
(reset (* 2
(shift f2 (* 3 (shift f3 7))))))))
(newline)
; haskeem quasi-fails this: because it's a (lambda () ...), it escapes,
; and so at the end there's an uncaught exception which however carries
; along the correct value as its payload. So I think haskeem would handle
; this correctly if there were an implicit top-level catcher
(write-string "should be 7\t\t")
(sandbox
(display (reset (* 5 (
(reset (* 2
(shift f2 (lambda ()
(* 3 (shift f3 7))))))))))
(newline))
(write-string "should be 42\t\t")
(display (reset (* 5
((lambda (x) (shift f1 x))
(* 3 (shift f2 (* 2 (f2 7))))))))
(newline)
(write-string "reset0/shift0 examples\n")
(write-string "should be 3\t\t")
(display (reset0 (* 2 (shift0 f 3))))
(newline)
(write-string "should be 30\t\t")
(display (reset0 (* 2 (shift0 f (* 5 (f 3))))))
(newline)
(write-string "should be 12\t\t")
(display (reset0 (* 2 (shift0 f (f (f 3))))))
(newline)
(write-string "should be 6\t\t")
(display ((reset0 (* 2 (shift0 f f))) 3))
(newline)
(write-string "should be 7\t\t")
(display (reset0 (* 5
(reset0 (* 2
(shift0 f2 (* 3 (shift0 f3 7))))))))
(newline)
(write-string "should be 7\t\t")
(sandbox
(display (reset0 (* 5 (
(reset0 (* 2
(shift0 f2 (lambda ()
(* 3 (shift0 f3 7))))))))))
(newline))
(write-string "should be 42\t\t")
(display (reset0 (* 5
((lambda (x) (shift0 f1 x))
(* 3 (shift0 f2 (* 2 (f2 7))))))))
(newline)
(write-string "something actually useful! a small table of factorials\n")
; Eventually we want to be able to use code like this:
; (defmacro (range from step to)
; (let ((f (gensym))
; (i (gensym)))
; `(shift ,f
; (do ((,i ,from (+ ,i ,step)))
; ((> ,i ,to) #f)
; (,f ,i)))))
;
; (reset (begin (display (my-fact (range 1 3 16))) (newline)))
; Just to show I've got nothing up my sleeve, here is a perfectly cromulent
; function; we could equally well use the built-in (factorial) function
(define (my-fact n)
(if (<= n 0)
1
(* n (my-fact (- n 1)))))
(define from 1)
(define to 21)
(define step 3)
(reset (display (my-fact
(shift f
(do ((i from (+ i step)))
((> i to) #f)
(write-string (number->string i))
(write-string "! =\t")
(f i)))))
(newline))
; This one is specific to haskeem, because the macro reset doesn't start
; the thunk in the middle, but rather at the beginning; that makes the
; ping-pong possible
(write-string
"These rely on the reset thunk being re-evaluated from the beginning,\n")
(write-string
"so strictly speaking both are wrong. So I don't know what the answers\n")
(write-string
"\"should be\"... but they look plausible\n")
(define (doit7 flag)
(display
(cons 1
(reset (cons 2 (if flag
(shift k1 (set! flag (not flag))
(cons 3 (k1 (cons 4 '()))))
(shift k2 (set! flag (not flag))
(cons 5 (k2 (cons 6 '())))))))))
(newline))
; it's hard to say if these are right... both rely on a wrong implementation
; of the thunk stuff
(doit7 #f) ; (1 5 3 2 6) -- mzscheme sez (1 5 2 6)
(doit7 #t) ; (1 3 5 2 4) -- mzscheme sez (1 3 2 4)
(write-string
"syntax error coming up! should be an error... this'll kill mzscheme\n")
(sandbox (display (+ 1 (reset (+ 2 (shift (+ k 1) 3))))))