;;;; shift-reset.scm
;;;; Kon Lovett, Apr 6 '06

;; Dynamically scoped shift/reset (Olivier Danvy & Andrzej Filinski)

(module shift-reset (;export
  ;;
  (%reset *%reset) (%shift *%shift)
  (reset *reset) (shift *shift)
  (%reset-values *%reset-values) (%shift-values *%shift-values)
  (reset-values *reset-values) (shift-values *shift-values)
  ;;
  *%reset *%shift
  *reset *shift
  *%reset-values *%shift-values
  *reset-values *shift-values)

  (import scheme
          (except chicken reset)
          (only miscmacros let/cc))

  (require-library miscmacros)

  (declare
		(always-bound
			*meta-dk*
			*meta-k*
			*meta-dkv*
			*meta-kv*))

(define-syntax %reset
  (syntax-rules ()
    ((_ BODY ...) (*%reset (lambda () BODY ...)) ) ) )

(define-syntax %shift
  (syntax-rules ()
    ((_ SP BODY ...) (*%shift (lambda (SP) BODY ...)) ) ) )

(define-syntax reset
  (syntax-rules ()
    ((_ BODY ...) (*reset (lambda () BODY ...)) ) ) )

(define-syntax shift
  (syntax-rules ()
    ((_ SP BODY ...) (*shift (lambda (SP) BODY ...)) ) ) )

(define-syntax %reset-values
  (syntax-rules ()
    ((_ BODY ...) (*%reset-values (lambda () BODY ...)) ) ) )

(define-syntax %shift-values
  (syntax-rules ()
    ((_ SP BODY ...) (*%shift-values (lambda (SP) BODY ...)) ) ) )

(define-syntax reset-values
  (syntax-rules ()
    ((_ BODY ...) (*reset-values (lambda () BODY ...)) ) ) )

(define-syntax shift-values
  (syntax-rules ()
    ((_ SP BODY ...) (*shift-values (lambda (SP) BODY ...)) ) ) )

;;
;; 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-k s r) (error s "no toplevel in scope" r))

;;
;; Single Valued - Without Dynamic-Wind
;;

(define *meta-dk* (lambda (val) (bad-k '%shift '%reset)))

(define (*%return EXPR) (##sys#direct-return *meta-dk* EXPR))

(define (*%reset thunk)
  (let ((meta-dk *meta-dk*))
    (let ((val (let/cdc k
                 (set! *meta-dk* k)
                 (*%return (thunk)))))
      (set! *meta-dk* meta-dk)
      val) ) )

(define (*%shift proc)
  (let/cdc k
    (*%return
      (proc
        (lambda (val)
          (*%reset
            (lambda ()
              (##sys#direct-return k val)))))) ) )

;;
;; Single Valued - With Dynamic-Wind
;;

(define *meta-k* (lambda (val) (bad-k 'shift 'reset)))

(define-syntax *return
  (syntax-rules ()
    ((_ EXPR) (*meta-k* EXPR)) ) )

(define (*reset thunk)
  (let ((meta-k *meta-k*))
    (let/cc k
      (set! *meta-k*
        (lambda (val)
          (set! *meta-k* meta-k)
          (k val)))
      (*return (thunk)) ) ) )

(define (*shift proc)
  (let/cc k
    (*return (proc (lambda (val) (*reset (lambda () (k val)))))) ) )

;;
;; Multi-Valued - Without Dynamic-Wind
;;

(define *meta-dkv* (lambda vals (bad-k '%shift-values '%reset-values)))

(define-syntax *%return-values
  (syntax-rules ()
    ((_ EXPR)
      (call-with-values
        (lambda () EXPR)
        (lambda vals (apply *meta-dkv* vals))) ) ) )

(define (*%reset-values thunk)
  (let ((meta-dkv *meta-dkv*))
    (call-with-values
      (lambda ()
        (let/scc k
          (set! *meta-dkv* k)
          (*%return-values (thunk))))
      (lambda vals
        (set! *meta-dkv* meta-dkv)
        (apply values vals))) ) )

(define (*%shift-values proc)
  (let/scc k
    (*%return-values (proc (lambda vals (*%reset-values (lambda () (apply k vals)))))) ) )

;;
;; Multi-Valued - With Dynamic-Wind
;;

(define *meta-kv* (void))

(define-syntax *return-values
  (syntax-rules ()
    ((_ EXPR CALLER)
      (if (continuation? *meta-kv*) (continuation-graft *meta-kv* (lambda () EXPR))
          (bad-k CALLER 'reset-values) ) ) ) )

(define (*reset-values thunk)
  (let ((meta-kv *meta-kv*))
    (call-with-values
      (lambda ()
        (let/ccp k
          (set! *meta-kv* k)
          (call-with-values
            thunk
            (lambda vals
              (*return-values (apply values vals) 'reset-values)))))
      (lambda vals
        (set! *meta-kv* meta-kv)
        (apply values vals))) ) )

(define (*shift-values proc)
  (let/ccp k
    (*return-values
      (proc (lambda vals (*reset-values (lambda () (apply continuation-return k vals)))))
      'shift-values) ) )

) ;module shift-reset