;;;; delimited-control.scm
;;;; Kon Lovett, Apr 6 '06

;; prompt, prompt0, reset, reset0 are synonyms

(module delimited-control (;export
  ;;
  (prompt *prompt) (prompt0 *prompt)
  (reset *prompt) (reset0 *prompt)
  (control *control) (control-abort *control)
  (control0 *control)
  (shift *control)
  (shift0 *control)
  ;;
  *prompt *control)

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

  (require-library miscmacros)

  (declare
		(always-bound
			*holes*))

;;;

(define-syntax prompt
	(syntax-rules ()
		((_ EXPR) (*prompt (lambda () EXPR))) ) )

(define-syntax prompt0
	(syntax-rules ()
		((_ EXPR) (*prompt (lambda () EXPR))) ) )

(define-syntax reset
	(syntax-rules ()
		((_ EXPR) (*prompt (lambda () EXPR))) ) )

(define-syntax reset0
	(syntax-rules ()
		((_ EXPR) (*prompt (lambda () EXPR))) ) )

;; +F-

(define-syntax control
	(syntax-rules ()
		((_ PP EXPR) (*control #f #t (lambda (PP) EXPR))) ) )

(define-syntax control-abort
	(syntax-rules ()
		((_ V) (*control #f #t (lambda (_) V))) ) )

;; -F-

(define-syntax control0
	(syntax-rules ()
		((_ PP EXPR) (*control #f #f (lambda (PP) EXPR))) ) )

;; +F+

(define-syntax shift
	(syntax-rules ()
		((_ PP EXPR) (*control #t #t (lambda (PP) EXPR))) ) )

;; -F+

(define-syntax shift0
	(syntax-rules ()
		((_ PP EXPR) (*control #t #f (lambda (PP) EXPR))) ) )

;; This is one single global mutable cell, holding the stack of holes
;;
;; A hole has a continuation and a mark. The mark, if #t, says if the
;; hole is a delimiting hole. A non-delimiting hole is just like the
;; return from a regular function.

(define *holes* '())

(define (hole-push! hole) (set! *holes* (cons hole *holes*)))

(define (hole-list-push! hole-lst)
  (when (pair? hole-lst)
    (let loop ((holes hole-lst))
      (let ((next-hole (cdr holes)))
        (if (not (null? next-hole)) (loop next-hole)
            (begin
              (set-cdr! holes *holes*)
              (set! *holes* hole-lst) ) ) ) ) ) )

(define (hole-pop*!)
	(let ((hole (car *holes*)))
		(set! *holes* (cdr *holes*))
		hole ) )

(define (hole-pop!)
  (if (not (null? *holes*)) (hole-pop*!)
      (error 'control "missing toplevel delimited control operator") ) )

(define (cell-new v mark) (cons v mark))

(define (cell-ref c) (car c))

(define (cell-marked? c) (cdr c))

;;

(define (unwind-till-marked! keep-delimited?)
  (let loop ((hole (hole-pop!)) (holes-prefix '()))
    (if (not (cell-marked? hole)) (loop (hole-pop!) (cons hole holes-prefix))
        ; marked, it's prompt's hole
        (begin
          ; put it back
          (hole-push! (if keep-delimited? hole
                          ; make the hole non-delimiting
                          (cell-new (cell-ref hole) #f)))
          holes-prefix ) ) ) )

;; Essentially this is the ``return from the function''

(define (*abort-top! v) ((cell-ref (hole-pop*!)) v))

(define (*prompt thunk)
	(let/cc outer-k
		(hole-push! (cell-new outer-k #t)) ; it's prompt's hole
		(*abort-top! (thunk)) ) )

(define (*control shift? keep-delimited? func)
  (let/cc k-control
		(let* ((holes-prefix (unwind-till-marked! keep-delimited?))
					 (invoke-subcont (lambda (v)
                             (let/cc k-return
                               (hole-push! (cell-new k-return shift?))
                               (hole-list-push! holes-prefix)
                               (k-control v)))) )
			(*abort-top! (func invoke-subcont)) ) ) )

) ;module delimited-control