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

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

(module shift-reset

(;export
  (reset $reset) (shift $shift))

(import scheme
  (chicken base)
  (chicken type)
  (chicken continuation))

(: $shift (procedure -> . *))
(: $reset (procedure -> . *))

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

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

;;
;; Local impl of continuation binding
;;

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

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

;NOTE these have similar performance on the tests

;NOTE the synch dynexn approach CAN be escaped!

(cond-expand
  (a-better-api
    (define *meta-kv* (make-parameter (void)))

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

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

    (define ($shift proc)
      (let/ccp k
        (*return
          (proc (lambda vals ($reset (lambda () (apply continuation-return k vals)))))
          'shift) ) ) )
  (else
    (import (only miscmacros let/cc))

    (define *meta-kv* (make-parameter (lambda vals (bad-k 'shift 'reset))))

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

    (define ($reset thunk)
      (let ((meta-k (*meta-kv*)))
        (let/cc k
          (*meta-kv* (lambda vals (*meta-kv* meta-k) (apply k vals)))
          (*return (thunk)) ) ) )

    (define ($shift proc)
      (let/cc k
        (*return (proc (lambda vals ($reset (lambda () (apply k vals)))))) ) ) ) )

) ;module shift-reset