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

;; Statically scoped shift/reset (Oleg Kiselyov)

(module bshift-breset (;export
  ;;
  (%breset *%breset) (%bshift *%bshift)
  (breset *breset) (bshift *bshift)
  (%breset-values *%breset-values) (%bshift-values *%bshift-values)
  (breset-values *breset-values) (bshift-values *bshift-values)
  ;;
  *%breset *%bshift
  *breset *bshift
  *%breset-values *%bshift-values
  *breset-values *bshift-values
  ;;
  $range-empty-tag)

  (import scheme chicken
          (only miscmacros let/cc)
          (only box make-box *box-structure? *box-structure-ref *box-structure-set!))

  (require-library miscmacros box)

(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) ) ) )

(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) ) ) )

(define-syntax %breset-values
  (syntax-rules ()
    ((_ RC BODY ...) (*%breset-values (lambda (RC) BODY ...) 'RC) ) ) )

(define-syntax %bshift-values
  (syntax-rules ()
    ((_ RC SP BODY ...) (*%bshift-values RC (lambda (SP) BODY ...) 'RC) ) ) )

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

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

;;
;; Local impl of continuation binding
;;

(define-syntax let/scc
  (syntax-rules ()
    ((_ K BODY ...) (##sys#call-with-current-continuation (lambda (K) BODY ...)) ) ) )

(define-syntax let/cdc
  (syntax-rules ()
    ((_ K BODY ...) (##sys#call-with-direct-continuation (lambda (K) BODY ...)) ) ) )

(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))

;;
;; Unique value for range macro
;;

(define ($range-empty-tag) $range-empty-tag)

;;
;; Single valued - Without Dynamic-Wind
;;

(define-syntax *%breturn
	(syntax-rules ()
		((_ RC EXPR RC-SYM CALLER)
      (let ((val EXPR) (rc RC))
        (if (not (*box-structure? rc)) (bad-dk CALLER RC-SYM)
            (let ((rc-k (*box-structure-ref rc)))
              (when (procedure? rc-k)
                (##sys#direct-return rc-k val) ) ) ) ) ) ) )

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

(define (*%bshift rc proc rc-sym)
  (let/cdc s-k
    (*%breturn rc
      (proc
        (lambda (val)
          (if (not (*box-structure? rc)) (bad-dk '%bshift rc-sym)
              (let ((old-rc (*box-structure-ref rc)))
                (let ((s-val
                        (let/cdc rc-k
                          (*box-structure-set! rc rc-k)
                          (##sys#direct-return s-k val))))
                  (*box-structure-set! rc old-rc)
                  s-val)))))
      rc-sym '%bshift) ) )

;;
;; Single valued - With Dynamic-Wind
;;

(define-syntax *breturn
	(syntax-rules ()
		((_ RC EXPR RC-SYM CALLER)
      (let ((val EXPR) (rc RC))
        (if (not (*box-structure? rc)) (bad-dk CALLER RC-SYM)
            (let ((rc-proc (*box-structure-ref rc)))
              (when (procedure? rc-proc)
                (rc-proc val) ) ) ) ) ) ) )

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

(define (*bshift rc proc rc-sym)
  (let/cc s-k
    (*breturn rc
      (proc
        (lambda (val)
          (if (not (*box-structure? rc)) (bad-dk 'bshift rc-sym)
              (let ((old-rc (*box-structure-ref rc)))
                (let ((s-val
                        (let/cc rc-k
                          (*box-structure-set! rc rc-k)
                          (s-k val))))
                  (*box-structure-set! rc old-rc)
                  s-val)))))
      rc-sym 'bshift) ) )

;;
;; Multiple valued - Without Dynamic-Wind
;;

(define-syntax *%breturn-values
	(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)))
                  (when (procedure? rc-k)
                    (apply rc-k vals)))))) ) ) ) )

(define (*%breset-values proc rc-sym)
  (let/scc rc-k
    (let ((rc (make-box rc-k)))
      (*%breturn-values rc (proc rc) rc-sym '%breset-values) ) ) )

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

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

(define-syntax *breturn-values
	(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)))
                  (when (continuation? rc-k)
                    (apply continuation-return rc-k vals)))))) ) ) ) )

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

(define (*bshift-values rc proc rc-sym)
  (let/ccp s-k
    (*breturn-values rc
      (proc
        (lambda vals
          (if (not (*box-structure? rc)) (bad-dk 'bshift-values 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-values) ) )

) ;module bshift-breset