;;;;
;;;; callcc.stk	-- R5RS call/cc function written in Scheme
;;;;
;;;; Copyright © 2000-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; 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)
;;;; Last file update: 24-Oct-2006 17:33 (eg)
;;;;

(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)
      (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)