Welcome to the CHICKEN Scheme pasting service

;	delimcc: Control operators for delimited continuations
;
; This library implements the variety of delimited control operators
; for R5RS Scheme. The code implements the superset of the interface
; proposed by Dybvig, Sabry, and Peyton-Jones.
; This library is the transcription into Scheme of the delimcc library of OCaml:
; http://okmij.org/ftp/Computation/Continuations.html#caml-shift
;
; Although the present code should work on any R5RS Scheme system,
; good performance should be expected only on the systems that implement
; call/cc efficiently, such as Chez Scheme, Scheme48, Gambit, Larceny.
;
;
; The library interface, based on delimcc.mli, is as follows:
;
; procedure new-prompt: 
;  (new-prompt) returns a fresh prompt, eq? only to itself.
;
; syntax: push-prompt
;  (push-prompt p e1 e2 ...)
; sets the prompt p and evaluates the sequence of expressions e1 e2 ...
; returning the result of the last one (unless take_subcont was executed)
;
; syntax: abortP
;  (abort p e) flushes the stack up to, and including, the dynamically closest
;  push-prompt with the prompt p; expression e is evaluated in the
;  remaining context.
;
; syntax take-subcont:
;  (take-subcont p sk e1 e2 ...)
; captures the continuation up to the dynamically closest push-prompt with
; the prompt p, and binds the captured delimited continuation object
; to the variable sk; the prompt is unset. The sequence of
; expressions e1 e2 ... is evaluated in the remaining context.
;
; syntax push-subcont:
;  (push-subcont sk e1 e2 ...)
; reinstates the delimited continuation represented by the object sk
; and then evaluates the sequence of expressions e1 e2 ...
;
; syntax push-delim-subcont:
;  (push-delim-subcont sk e1 e2 ...)
; is like (push-subcont sk e1 e2 ...) but inserts push-prompt
; underneath of the reinstated sk.
; 
; syntax shift:
;  (shift p f e1 e2 ...)
; is a multi-prompt shift. The captured continuation is reified as a function
; and bound to the variable f.
;
; syntax shift0:
;  (shift0 p f e1 e2 ...)
; is multi-prompt shift0. The captured continuation is reified as a function
; and bound to the variable f. After the continuation is captured,
; push-prompt p is removed.
;
; syntax control:
;  (control p f e1 e2 ...)
; is a multi-prompt control. The captured continuation is reified as a function
; and bound to the variable f. The captured continuation is not delimited
; by push-prompt.
;
; procedure prompt-set?:
;  (prompt-set? p) returns a boolean value indicating if the current context
; contains push-prompt p.
;
; The code is a straightforward re-implementation of delimcc.ml.
; Scheme trivially supports scAPI: exception handling is done with call/cc.
; In addition, systems like Chez Scheme or Scheme48 (with the hybrid
; stack/heap or segmented stack strategies) do handle control stack overflow.
; Continuation capture is quite like control stack overflow.
;
; We can attempt to use the dynamic-wind mechanism to maintain
; the pstack. In that case, a prompt could be a ref cell holding
; push-prompt's recent continuation, and dynamic-wind would
; take care of maintaining the invariant that prompt contains the continuation
; of the closest push-prompt.
; OTH, that seems quite a complex mechanism.
; In the following, we go for clarity, and for similarity with the
; the OCaml implementation.

; This ought to be a call-with-unwinding-continuation, if an
; implementation provides such a thing.
(define call/cc call-with-current-continuation)


; pstack is an associative list of (prompt . k), just like in OCaml
(define pstack '())

; Execute a thunk in the empty environment -- at the bottom of the stack --
; and pass the result, too encapsulated as a thunk, to the
; continuation at the top of pstack. The latest pstack frame is
; removed.
;
; We rely on the insight that the capture of a delimited continuation
; can be reduced to the capture of the undelimited one. We invoke 
; (go th) to execute the thunk th in the delimited context. 
; The call to 'go' is evaluated almost in the empty context
; (near the `bottom of the stack'). Therefore,
; any call/cc operation encountered during the evaluation of th
; will capture at most the context established by the 'go' call, NOT
; including the context of go's caller. Informally, invoking (go th)
; creates a new stack segment; continuations captured by call/cc
; cannot span the segment boundaries, and are hence delimited.
; 
; This emulation of delimited control is efficient providing that
; call/cc is implemented efficiently, with the hybrid heap/stack or
; stack segment strategies.

; The corresponding OCaml code, from delimcc, is as follows.
; Please see delimcc.ml for explanations.
;; let push_prompt (p : 'a prompt) (body : unit -> 'a) : 'a =
;;   try
;;     push_prompt_aux p body
;;   with
;;   | DelimCCE -> (match !ptop with
;;     | h::t -> assert (h.pfr_mark == p.mark); ptop := t; mbox_receive p
;;     | _ -> dbg_fatal_error "push_prompt: empty pstack on DelimCCE")
;;   | e -> match !ptop with
;;     | h::t -> assert (h.pfr_mark == p.mark); ptop := t; 
;; 	dbg_note "propagating exc"; raise e
;;     | _ -> dbg_fatal_error "push_prompt: empty pstack on other exc"

(define go #f)
(let ((v
	(call/cc
	  (lambda (k)
	    (set! go k)
	    (k #f)))))
  (if v
    (let* ((r (v))
	   (h (car pstack))
	   (_ (set! pstack (cdr pstack))))
      ((cdr h) (lambda () r)))	; does not return
    ))

; As in OCaml, a prompt is a ref unit. We rely on generativity of ref cells
(define (new-prompt) (list #f))

;; let push_prompt_aux (p : 'a prompt) (body : unit -> 'a) : 'a =
;;   let ek = get_ek () in
;;   let pframe = {pfr_mark = p.mark; pfr_ek = ek} in
;;   let () = ptop := pframe :: (!ptop) in
;;   let res = body () in
;;   let () = p.mbox := fun () -> res in
;;   raise DelimCCE

(define (push-prompt* p th)
  ((call/cc
     (lambda (k)
       (set! pstack (cons (cons p k) pstack))
       (go th)))))			; does not return

;; let rec unwind acc mark = function
;;   | []   -> failwith "No prompt was set" 
;;   | h::t as s -> if h.pfr_mark == mark (* Physical equality ! *)
;;                  then (h,s,acc) else unwind (h::acc) mark t

(define (unwind acc p pstack)
  (if (null? pstack) (error "No prompt was set")
    (if (eq? p (caar pstack))
      (cons pstack acc)
      (unwind (cons (car pstack) acc) p (cdr pstack)))))

; The same as above, but the removed frames are disregarded
(define (unwind-abort p pstack)
  (if (null? pstack) (error "No prompt was set")
    (if (eq? p (caar pstack))
      pstack
      (unwind-abort p (cdr pstack)))))

;; let take_subcont (p : 'b prompt) (f : ('a,'b) subcont -> unit -> 'b) : 'a =
;;   let pa = new_prompt () in
;;   push_prompt_simple pa
;;     (fun () ->
;;       let (h,s,subcontchain) = unwind [] p.mark !ptop in
;;       let () = ptop := s in
;;       let ek = h.pfr_ek in
;;       let sk = get_ek () in
;;       let ekfrag = pop_stack_fragment ek sk in
;;       p.mbox := 
;;       f {subcont_ek = ekfrag; subcont_pa = pa;
;; 	 subcont_pb = p; subcont_ps = subcontchain;
;;          subcont_bs = ek})

; the captured continuation object is a vector of three elements:
;  k  -- ekfragment, the captured continuation itself
;  p  -- the prompt that delimited the continuation
;  subchain --  the part of the pstack corresponding to k,
;               in the reverse pframe order.

(define (take-SC p f)
  ((call/cc
    (lambda (k)			; stack fragment
      (let* ((subchain-pstack (unwind '() p pstack))
             (_ (set! pstack (car subchain-pstack)))
             (subchain (cdr subchain-pstack)))
        (go (f (vector k p subchain)))))))) ; returns when k is invoked

;; let push_subcont (sk : ('a,'b) subcont) (m : unit -> 'a) : 'b =
;;   let pb = sk.subcont_pb in
;;   push_prompt_simple pb (fun () ->
;;     let base = sk.subcont_bs in
;;     let ek = get_ek () in
;;     List.iter (fun pframe ->
;;       ptop := {pframe with pfr_ek = add_ek ek (sub_ek pframe.pfr_ek base)} ::
;; 	    !ptop) sk.subcont_ps;
;;     sk.subcont_pa.mbox := m;
;;     push_stack_fragment sk.subcont_ek)

(define (push-SC sk m)
  ((call/cc
    (lambda (k)
      (let ((p** (new-prompt))
            (ekfragment (vector-ref sk 0))
            (subchain (vector-ref sk 2)))
        (set! pstack (cons (cons p** k) pstack))
        (for-each
         (lambda (frame)
           (set! pstack (cons frame pstack)))
         subchain)
        (ekfragment m))))))

(define (push-delim-SC sk m)
  ((call/cc
    (lambda (k)
      (let ((p (vector-ref sk 1))
            (ekfragment (vector-ref sk 0))
            (subchain (vector-ref sk 2)))
        (set! pstack (cons (cons p k) pstack))
        (for-each
         (lambda (frame)
           (set! pstack (cons frame pstack)))
         subchain)
        (ekfragment m))))))

; A more efficient variation of take-SC, which does not capture
; any continuation.
(define (abort* p th)
  (let* ((pstack-new (unwind-abort p pstack))
	 (h (car pstack-new)))
    (set! pstack (cdr pstack-new))
    ((cdr h) th)))			; does not return

; Check to see if a prompt is set
(define (prompt-set? p)
  (assq p pstack))

; ------------------------------- Syntactic sugar

(define-syntax push-prompt
  (syntax-rules ()
    ((_ p e1 e2 ...) (push-prompt* p (lambda () e1 e2 ...)))))

(define-syntax abortP
  (syntax-rules ()
    ((_ p e) (abort* p (lambda () e)))))


(define-syntax take-subcont
  (syntax-rules ()
    ((_ p sk e1 e2 ...)
      (take-SC p (lambda (sk) (lambda () e1 e2 ...))))))

(define-syntax push-subcont
  (syntax-rules ()
    ((_ sk e1 e2 ...)
      (push-SC sk (lambda () e1 e2 ...)))))

(define-syntax push-delim-subcont
  (syntax-rules ()
    ((_ sk e1 e2 ...)
      (push-delim-SC sk (lambda () e1 e2 ...)))))

;; LK: +F+
;; The reified continuation takes a value rather than an action
(define-syntax shift
  (syntax-rules ()
    ((_ p f e1 e2 ...)
     (take-subcont p sk
                   (let ((f (lambda (v) (push-delim-subcont sk v))))
                     (push-prompt p e1 e2 ...))))))

;; LK: -F+
(define-syntax shift0
  (syntax-rules ()
    ((_ p f e1 e2 ...)
     (take-subcont p sk
                   (let ((f (lambda (v) (push-delim-subcont sk v))))
                     e1 e2 ...)))))

;; LK: +F-
(define-syntax control
  (syntax-rules ()
    ((_ p f e1 e2 ...)
     (take-subcont p sk
                   (let ((f (lambda (v) (push-subcont sk v))))
                     (push-prompt p e1 e2 ...))))))

;; LK: -F-
;; LK: my addition
(define-syntax control0
  (syntax-rules ()
    ((_ p f e1 e2 ...)
     (take-subcont p sk
                   (let ((f (lambda (v) (push-subcont sk v))))
                     e1 e2 ...)))))

;; LK: references: https://d-nb.info/1213720753/34

(let ((p (new-prompt)))
  (display (+ 10 (push-prompt p (+ 2 (shift p k (+ 100 (k (k 3)))))))))
(newline)
;; --> 117

(let ((p (new-prompt)))
  (display (* 10 (push-prompt p (* 2 (shift p g (* 5 (shift p f (+ (f 1) 1)))))))))
(newline)
;; --> 60

(let ((p (new-prompt)))
  (display (let ((f (lambda (x) (shift p k (k (k x))))))
             (+ 1 (push-prompt p (+ 10 (f 100)))))))
(newline)
;; --> 121

(let ((p (new-prompt)))
  (display (push-prompt p
            (let ((x (shift p f 
                            (shift p f1 (f1 (cons 'a (f '())))))))
              (shift p g x)))))
(newline)
;; ==> '(a)

;; # let get () =shift (fun k -> fun state -> k state state) ;;get : unit => 'a = 

;; # let tick () =shift (fun k -> fun state -> k () (state + 1)) ;;tick : unit => unit = 

;; # let run_state thunk =
;;       reset (fun () -> let result = thunk () in
;;                        fun state -> result) 0
;;run_state : (unit => 'a) => 'b = 

;; # run_state (fun () ->
;;     tick ();(* state = 1 *)
;;     tick ();(* state = 2 *)
;;     let a = get () in
;;     tick ();
;;     (* state = 3 *)
;;     get () - a)
;;- : int = 1

;; run_state (fun () ->(tick (); get ()) - (tick (); get ())) ;;

;; (define (get p)
;;   (shift p k
;;          (lambda (state)
;;            (k state state))))

;; (define (tick p)
;;   (shift p k
;;          (lambda (state)
;;            (k '() (+ state 1)))))

;; (define (run-state th)
;;   (let ((p (new-prompt)))
;;     (push-prompt p
;;                  (let ((result (th p)))
;;                    (lambda (state) result))) 0))

;; (display "will try")
;; (newline)

;; (run-state
;;  (lambda (p)
;;    (display "even here? 1")
;;    (newline)
;;    (tick p)
;;    (tick p)
;;    (display "even here? 2")
;;    (newline)
;;    (let ((a (get p)))
;;      (display a)
;;      (newline))
;;    (tick p)
;;    (let ((a (get p)))
;;      (display a)
;;      (newline))))

;; (display "done")
;; (newline)

;; (exit)

;; (let ((p (new-prompt)))
;;   (let ((th (lambda ()
;;               (display "here?")
;;               ;; tick
;;               (shift p k (lambda (s) (k '() (+ s 1))))
;;               ;; tick
;;               (shift p k (lambda (s) (k '() (+ s 1))))
;;               ;; get
;;               (let ((r (shift p k (lambda (s) (k s s)))))
;;                 (display r))
;;               ;; tick
;;               (shift p k (lambda (s) (k '() (+ s 1))))
;;               ;; get
;;               (let ((r (shift p k (lambda (s) (k s s)))))
;;                 (display r)))))
;;     (push-prompt p
;;                  (let ((result (th)))
;;                    (lambda (s) result))) 0))
;; (exit)

(define (get p) (shift0 p k (lambda (v) (k v v))))

(define (put v p) (shift p k (lambda (unused) (k '() v))))

(define what #f)

(let ((p (new-prompt)))
  (set! what (push-prompt p (get p))))

(newline)