; Generic implementation of all four delimited control operators
;    shift/reset, prompt/control, shift0/reset0 and prompt0/control0
;                   aka. -F- through +F+  
;
; The code below is parameterized by two boolean flags:
; is-shift and keep-delimiter-upon-effect.
; Each flag is present in the code exactly once, in a trivial
; context. In particular, the difference between shift and control is
; one statement: (hole-push! (cell-new k-return is-shift))
; which tells whether the created hole is delimiting or not.
; All four combinations of the two flags correspond to four
; delimited control operators,  -F- through +F+
;
; The code relies on call/cc for capturing undelimited
; continuations, and uses one global mutable cell. It turns out, this
; is sufficient for implementing not only shift/reset (Danvy/Filinski)
; but also for control/prompt and the other F operators. That has not
; been known before. In particular, the implementation of
; control/prompt needs no eq? operations.
;
; This implementation immediately leads to a CPS transform for
; control/prompt (which has not been known before either). That
; transform turns almost identical to the one discussed in the
; forth-coming paper ``A Monadic Framework for Delimited
; Continuations'' by R. Kent Dybvig, Simon Peyton Jones and Amr Sabry
;
; This code is inspired by CC_Ref.hs -- contexts with holes, while reading
; Dorai Sitaram and Matthias Felleisen paper (Lisp and symbolic computation,
; 1990)
; A hole has a continuation and a mark. The mark, if #t, says if the hole
; is a delimiting hole.
; Non-delimiting hole is just like the return from a regular function.
;
; $Id: delim-control-n.scm 815 2005-09-05 23:02:12Z oleg $
(module delim-control mzscheme
  (provide prompt*
           control*
           abort
           prompt
           control
           shift
           reset
           prompt0
           control0
           shift0)
  
  ; This is one single global mutable cell
  (define holes '())
  (define (hole-push! hole) (set! holes (cons hole holes)))
  (define (hole-pop!) (let ((hole (car holes))) (set! holes (cdr holes)) hole))
  
  (define (cell-new v mark) (cons v mark))
  (define (cell-ref c) (car c))
  (define (cell-marked? c) (cdr c))
  
  ; Essentially this is the ``return from the function''
  (define (abort-top! v) ((cell-ref (hole-pop!)) v))
  (define (unwind-till-marked! keep-delimiter-upon-effect)
    (if (null? holes) (error "No prompt set"))
    (let ((hole (hole-pop!)))
      (if (cell-marked? hole)		; if marked, it's prompt's hole
          (begin (hole-push!		; put it back
                  (if keep-delimiter-upon-effect
                      hole
                      (cell-new (cell-ref hole) #f))) ; make the hole non-delimiting
                 '())	
          (cons hole (unwind-till-marked! keep-delimiter-upon-effect)))))
  
  (define (prompt* thunk)
    (call-with-current-continuation
     (lambda (outer-k)
       (hole-push! (cell-new outer-k #t)) ; it's prompt's hole
       (abort-top! (thunk)))))
  
  (define (control* is-shift keep-delimiter-upon-effect f)
    (call-with-current-continuation
     (lambda (k-control)
       (let* ((holes-prefix (reverse (unwind-till-marked! keep-delimiter-upon-effect)))
              (invoke-subcont 
	       (lambda (v)
		 (call-with-current-continuation
                  (lambda (k-return)
                    (hole-push! (cell-new k-return is-shift))
                    (for-each hole-push! holes-prefix)
                    (k-control v))))))
         (abort-top! (f invoke-subcont))))))
  
  (define (abort v) (control* #f #t (lambda (k) v)))
  
  ; Some syntactic sugar
  (define-syntax prompt
    (syntax-rules ()
      ((prompt e) (prompt* (lambda () e)))))  
  (define-syntax control
    (syntax-rules ()
      ((control f e) (control* #f #t (lambda (f) e)))))
  
  ; introduce convenient synonyms 
  (define-syntax reset
    (syntax-rules ()
      ((reset e) (prompt e))))  
  (define-syntax shift
    (syntax-rules ()
      ((shift f e) 
       (control* #t #t (lambda (f) e)))))
  
  (define-syntax prompt0
    (syntax-rules ()
      ((prompt0 e) (prompt e))))
  (define-syntax control0
    (syntax-rules ()
      ((control f e) (control* #f #f (lambda (f) e)))))
  
  (define-syntax shift0
    (syntax-rules ()
      ((shift0 f e) 
       (control* #t #f (lambda (f) e))))))