;;;; bshift-breset.scm
;;;; Kon Lovett, Apr 6 '06

;; Statically scoped shift/reset (Oleg Kiselyov)

(module bshift-breset

(;export
  (breset $breset) (bshift $bshift))

(import scheme
  (chicken base)
  (chicken type)
  (chicken continuation)
  (only box-core make-box *box-structure? *box-structure-ref *box-structure-set!))

;NOTE needs CHICKEN 5.3.1
(include "box.types")

(: $bshift (box procedure symbol -> . *))
(: $breset (procedure symbol -> . *))

(define-syntax breset
  (syntax-rules ()
    ((_ RC BODY ...) ($breset (lambda (RC) BODY ...) 'RC) ) ) )

(define-syntax bshift
  (syntax-rules ()
    ((_ RC SP BODY ...) ($bshift RC (lambda (SP) BODY ...) 'RC) ) ) )

;;
;; Local impl of continuation binding
;;

(define-syntax let/ccp
  (syntax-rules ()
    ((_ K BODY ...) (continuation-capture (lambda (K) BODY ...)) ) ) )

;;
;; Common error
;;

(define (bad-dk s r) (error s "no toplevel in scope" r))

;;
;; Multiple valued - With Dynamic-Wind
;;

(define-syntax *breturn
	(syntax-rules ()
		((_ RC EXPR RC-SYM CALLER)
      (let ((rc RC))
        (call-with-values
          (lambda () EXPR)
          (lambda vals
            (if (not (*box-structure? rc)) (bad-dk CALLER RC-SYM)
                (let ((rc-k (*box-structure-ref rc)))
                  (if (not (continuation? rc-k)) (bad-dk CALLER RC-SYM)
                      (apply continuation-return rc-k vals)))))) ) ) ) )

(define ($breset proc rc-sym)
  (let/ccp rc-k
    (let ((rc (make-box rc-k)))
      (*breturn rc (proc rc) rc-sym 'breset) ) ) )

(define ($bshift rc proc rc-sym)
  (let/ccp s-k
    (*breturn rc
      (proc
        (lambda vals
          (if (not (*box-structure? rc)) (bad-dk 'bshift rc-sym)
              (let ((old-rc (*box-structure-ref rc)))
                (call-with-values
                  (lambda ()
                    (let/ccp rc-k
                      (*box-structure-set! rc rc-k)
                      (apply continuation-return s-k vals)))
                  (lambda s-vals
                    (*box-structure-set! rc old-rc)
                    (apply values s-vals)))))))
      rc-sym 'bshift) ) )

) ;module bshift-breset