;;;;
;;;; callcc.stk -- R5RS call/cc function written in Scheme
;;;;
;;;; Copyright © 2000-2023 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date:  3-Apr-2006 12:27 (eg)
;;;;

(export call/cc call-with-current-continuation dynamic-wind)

#|
<doc call-with-current-continuation call/cc
 * (call-with-current-continuation proc)
 * (call/cc proc)
 *
 * |Proc| must be a procedure of one argument. The procedure
 * |call-with-current-continuation| packages up the current continuation
 * (see the rationale below) as an "_escape procedure_" and passes it as
 * an argument to |proc|. The escape procedure is a Scheme procedure that, if
 * it is later called, will abandon whatever continuation is in effect at
 * that later time and will instead use the continuation that was in effect
 * when the escape procedure was created. Calling the escape procedure may cause
 * the invocation of before and after thunks installed using |dynamic-wind|.
 * @l
 * The escape procedure accepts the same number of arguments as
 * the continuation to the original call to
 * |call-with-current-continuation|. Except for continuations created
 * by the |call-with-values| procedure, all continuations take exactly
 * one value.
 * @l
 * The escape procedure that is passed to proc has unlimited extent
 * just like any other procedure in Scheme. It may be stored in variables
 * or data structures and may be called as many times as desired.
 * @l
 * The following examples show only the most common ways in which
 * |call-with-current-continuation| is used. If all real uses were as simple
 * as these examples, there would be no need for a procedure with the power
 * of |call-with-current-continuation|.
 *
 * @lisp
 * (call-with-current-continuation
 *   (lambda (exit)
 *     (for-each (lambda (x)
 *                 (if (negative? x)
 *                     (exit x)))
 *               '(54 0 37 -3 245 19))
 *     #t))                                =>  -3
 *
 * (define list-length
 *   (lambda (obj)
 *     (call-with-current-continuation
 *       (lambda (return)
 *         (letrec ((r
 *                   (lambda (obj)
 *                     (cond ((null? obj) 0)
 *                           ((pair? obj)
 *                            (+ (r (cdr obj)) 1))
 *                           (else (return #f))))))
 *           (r obj))))))
 *
 * (list-length '(1 2 3 4))                =>  4
 * (list-length '(a b . c))                =>  #f
 * @end lisp
 *
 * IMPORTANT: common use of |call-with-current-continuation|
 * is for structured, non-local exits from loops or procedure bodies,
 * but in fact |call-with-current-continuation| is extremely useful
 * for implementing a wide variety of advanced control structures.
 *
 * Whenever a Scheme expression is evaluated there is a continuation
 * wanting the result of the expression. The continuation represents
 * an entire (default) future for the computation. If the expression
 * is evaluated at top level, for example, then the continuation
 * might take the result, print it on the screen, prompt for the
 * next input, evaluate it, and so on forever. Most of the time the
 * continuation includes actions specified by user code, as in a
 * continuation that will take the result, multiply it by the value
 * stored in a local variable, add seven, and give the answer to the
 * top level continuation to be printed. Normally these ubiquitous
 * continuations are hidden behind the scenes and programmers do not
 * think much about them. On rare occasions, however, a programmer
 * may need to deal with continuations explicitly.
 * |Call-with-current-continuation| allows Scheme
 * programmers to do that by creating a procedure that acts just
 * like the current continuation.
 * @l
 * NOTE: |call/cc| is just another name for
 * |call-with-current-continuation|.
doc>
|#
#|
<doc dynamic-wind
 * (dynamic-wind before thunk after)
 *
 * Calls |thunk| without arguments, returning the result(s) of this call.
 * |Before| and |after| are called, also without arguments, as required by
 * the following rules (note that in the absence of calls to continuations
 * captured using |call-with-current-continuation| the three arguments are
 * called once each, in order).  |Before| is called whenever execution enters
 * the dynamic extent of the call to |thunk| and |after| is called whenever
 * it exits that dynamic extent.  The dynamic extent of a procedure call is
 * the period between when the call is initiated and when it returns.
 * In Scheme, because of |call-with-current-continuation|, the dynamic
 * extent of a call may not be a single, connected time period. It is
 * defined as follows:
 *
 * - The dynamic extent is entered when execution of the body of
 *   the called procedure begins.
 *
 * - The dynamic extent is also entered when execution is not
 *   within the dynamic extent and a continuation is invoked that was
 *   captured (using |call-with-current-continuation|) during the dynamic
 *   extent.
 *
 * - It is exited when the called procedure returns.
 *
 * - It is also exited when execution is within the dynamic
 *   extent and a continuation is invoked that was captured while not within
 *   the dynamic extent.
 *
 * If a second call to |dynamic-wind| occurs within the dynamic extent
 * of the call to |thunk| and then a continuation is invoked in such a
 * way that the afters from these two invocations of |dynamic-wind|
 * are both to be called, then the after associated with the
 * second (inner) call to |dynamic-wind| is called first.
 *
 * If a second call to |dynamic-wind| occurs within the dynamic extent
 * of the call to |thunk| and then a continuation is invoked in such a
 * way that the befores from these two invocations of |dynamic-wind|
 * are both to be called, then the before associated with the
 * first (outer) call to |dynamic-wind| is called first.
 *
 * If invoking a continuation requires calling the |before| from one
 * call to |dynamic-wind| and the |after| from another, then the |after|
 * is called first.
 *
 * The effect of using a captured continuation to enter or exit the
 * dynamic extent of a call to |before| or |after| is undefined.
 *
 * @lisp
 * (let ((path '())
 *       (c #f))
 *   (let ((add (lambda (s)
 *                (set! path (cons s path)))))
 *     (dynamic-wind
 *       (lambda () (add 'connect))
 *       (lambda ()
 *         (add (call-with-current-continuation
 *                (lambda (c0)
 *                  (set! c c0)
 *                  'talk1))))
 *       (lambda () (add 'disconnect)))
 *     (if (< (length path) 4)
 *         (c 'talk2)
 *         (reverse path))))
 *                   =>  (connect talk1 disconnect
 *                        connect talk2 disconnect)
 * @end lisp
doc>
|#

(define (%call/cc proc)
  ;; A simple continuation without winding (accepts multiples values)
  (let ((k  (%make-continuation)))
    (if  (%fresh-continuation? k)
         (proc (lambda v
                 (%restore-continuation k v)))
         (apply values k))))

;(define %dynamic-wind-stack (make-parameter (list #f)))

(define call/cc #f)
(define dynamic-wind #f)

(let ()

  (define (reroot! there)
      (unless (eq? (%thread-dynwind-stack) there)
        (reroot! (cdr there))
        (let ((before (caar there))
              (after  (cdar there))
              (here   (%thread-dynwind-stack)))
          (set-car! here (cons after before))
          (set-cdr! here  there)
          (set-car! there #f)
          (set-cdr! there '())
          (%thread-dynwind-stack-set! there)
          (before))))

  ;;
  ;; call/cc
  ;;
  (set! call/cc
    (lambda  (proc)
      (let ((here (%thread-dynwind-stack)))
        (%call/cc (lambda (cont)
                    (proc (lambda results
                            (reroot! here)
                            (apply cont results))))))))

  ;;
  ;; dynamic-wind
  ;;
  (set! dynamic-wind
    (lambda (before during after)
      #:dynamic-wind

      (define (verify-proc p)
        (unless (procedure? p)  ; Should test it is a thunk
          (error 'dynamic-wind "bad procedure ~S" p)))

      (verify-proc before)
      (verify-proc during)
      (verify-proc after)

      (let ((here (%thread-dynwind-stack)))
        (reroot! (cons (cons before after) here))
        (with-handler (lambda (c)
                        (reroot! here)
                        (raise c))
                      (call-with-values during
                        (lambda results (reroot! here) (apply values results))))))))

;;
;; call-with-current-continuation
;;
(define call-with-current-continuation call/cc)     ;; also set the procedure-name
