;;;; generalized-opers-test.scm
;;;; bshift-breset+range-test.scm
;;;; Kon Lovett, Apr 6 '06

;
(import utf8)
(import test)

(import (only (chicken format) format) (test-utils gloss))

;;;

(import gshift-greset)

;; Generalized shift/reset implementations of some control operators

(define-syntax prompt
  (syntax-rules ()
    ((_ e) (greset hr-stop e)) ) )

(define-syntax control
  (syntax-rules ()
    ((_ f e) (gshift hs-prop f e)) ) )

(define-syntax prompt0
  (syntax-rules ()
    ((_ e) (greset hr-prop e)) ) )

(define-syntax shift0
  (syntax-rules ()
    ((_ f e) (gshift hs-stop f e)) ) )

;;;

(test-group "gshift/greset"

  (test 117 (+ 10 (prompt (+ 2 (control k (+ 100 (k (k 3))))))))

  (test '() (prompt (let ((x (control f (cons 'a (f '()))))) (control g x))))

  (test 2 (prompt ((lambda (x) (control l 2)) (control l (+ 1 (l 0))))))

  (test '(a) (prompt (control f (cons 'a (f '())))))

  (test '(a) (prompt (let ((x (control f (cons 'a (f '()))))) (control g (g x)))))

  (test 117 (+ 10 (prompt0 (+ 2 (control k (+ 100 (k (k 3))))))))

  (test '() (prompt0 (prompt0 (let ((x (control f (cons 'a (f '()))))) (control g x)))))

  (test 117 (+ 10 (prompt0 (+ 2 (shift0 k (+ 100 (k (k 3))))))))

  (test '() (prompt0 (cons 'a (prompt0 (shift0 f (shift0 g '()))))))

  (test '(a) (prompt0 (cons 'a (prompt0 (prompt0 (shift0 f (shift0 g '())))))))
)

(test-exit)