;;; -*- Mode: Scheme -*-

;;;; Fshift & Freset
;;;; Labelled Composable Continuations

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

(define-record-type :control-marker
  (%make-control-marker continuation)
  control-marker?
  (continuation control-marker-continuation
            set-control-marker-continuation!))

(define (make-control-marker)
  (letrec ((marker
            (%make-control-marker
             (lambda (value)
               (error "No top-level FRESET" marker value)))))
    marker))

(define-syntax freset
  (syntax-rules ()
    ((FRESET marker body)
     (*FRESET marker (LAMBDA () body)))))

(define-syntax freset*
  (syntax-rules ()
    ((FRESET* marker-var body)
     (LET ((marker-var (MAKE-CONTROL-MARKER)))
       (FRESET marker-var body)))))

(define-syntax fshift
  (syntax-rules ()
    ((FSHIFT marker var body)
     (*FSHIFT marker (LAMBDA (var) body)))))

(define (*freset marker body)
  (let ((saved-cont (control-marker-continuation marker)))
    (call-with-current-continuation
      (lambda (k)
        (set-control-marker-continuation!
         marker
         (lambda (value)
           (set-control-marker-continuation! marker saved-cont)
           (k value)))
        (let ((result (body)))
          ;** Do not beta-substitute!
          ((control-marker-continuation marker) result))))))

(define (*fshift marker body)
  (call-with-current-continuation
    (lambda (k)
      (let ((result (body (lambda (value)
                            (*freset marker
                                     (lambda ()
                                       (k value)))))))
        ;** Do not beta-substitute!
        ((control-marker-continuation marker) result)))))

;;;; Examples

;;; Most of these are translated directly from Oleg's bshift & breset
;;; examples.

(freset* marker (+ 1 (fshift marker k 2)))
;Value: 2

(freset* marker (+ 1 (fshift marker k (+ 2 (k 3)))))
;Value: 6

(* 10 (freset* m1 (* 2 (* 5 (fshift m1 f (+ (f 1) 1))))))
;Value: 110

(* 10 (freset* m1 (* 2 (freset* m2 (* 5 (fshift m1 f (+ (f 1) 1)))))))
;Value: 110

(* 10 (freset* m1 (* 2 (freset* m2 (fshift m1 f (* 5 (fshift m1 g (+ (f 1) (g 1)))))))))
;Value: 70

(* 10 (freset* m1 (* 2 (fshift m1 g (freset* m2 (* 5 (fshift m2 f (+ (f 1) 1))))))))
;Value: 60

(* 10 (freset* m1 (* 2 (fshift m1 g (freset* m2 (* 5 (fshift m2 f (+ (f 1) (g 1)))))))))
;Value: 70

(* 10 (freset* m1 (* 2 (freset* m2 (fshift m1 g (* 5 (fshift m2 f (+ (f 1) 1))))))))
;Value: 50