From 60ddcb625bbda9ae1066c4c1b931ee0bb189fb6a Mon Sep 17 00:00:00 2001
From: Kevin Cozens <kcozens@cvs.gnome.org>
Date: Tue, 4 Aug 2009 19:08:26 -0400
Subject: [PATCH] Applied changes from CVS version 1.4 of init.c in official
 version of TinyScheme. Added unwind-protect (from Tom Breton).

---
 plug-ins/script-fu/tinyscheme/init.scm | 110 ++++++++++++++++++++++++-
 1 file changed, 109 insertions(+), 1 deletion(-)

diff --git a/plug-ins/script-fu/tinyscheme/init.scm b/plug-ins/script-fu/tinyscheme/init.scm
index 32ee86af52..f33b887c0c 100644
--- a/plug-ins/script-fu/tinyscheme/init.scm
+++ b/plug-ins/script-fu/tinyscheme/init.scm
@@ -84,7 +84,6 @@
              (abs (* (quotient aa (gcd aa bb)) bb)))))))
 
 
-(define call/cc call-with-current-continuation)
 
 (define (string . charlist)
      (list->string charlist))
@@ -315,6 +314,115 @@
                                          (foo level (cdr form)))))))))
    (foo 0 (car (cdr l)))))
 
+;;;;;Helper for the dynamic-wind definition.  By Tom Breton (Tehom)
+(define (shared-tail x y)
+   (let (  (len-x (length x)) 
+	   (len-y (length y)))
+      (define (shared-tail-helper x y)
+	 (if
+	    (eq? x y) 
+	    x
+	    (shared-tail-helper (cdr x) (cdr y))))
+      (cond
+	 ((> len-x len-y) 
+	    (shared-tail-helper
+	       (list-tail x (- len-x len-y))
+	       y))
+	 ((< len-x len-y) 
+	    (shared-tail-helper
+	       x
+	       (list-tail y (- len-y len-x))))
+	 (#t (shared-tail-helper x y)))))
+
+;;;;;Dynamic-wind by Tom Breton (Tehom)
+
+;;Guarded because we must only eval this once, because doing so
+;;redefines call/cc in terms of old call/cc
+(unless (defined? 'dynamic-wind)
+   (let
+      ;;These functions are defined in the context of a private list of
+      ;;pairs of before/after procs.
+      (  (*active-windings* '())
+	 ;;We'll define some functions into the larger environment, so
+	 ;;we need to know it.
+	 (outer-env (current-environment)))
+
+      ;;Poor-man's structure operations
+      (define before-func car)
+      (define after-func  cdr)
+      (define make-winding cons)
+
+      ;;Manage active windings
+      (define (activate-winding! new) 
+	 ((before-func new))
+	 (set! *active-windings* (cons new *active-windings*)))
+      (define (deactivate-top-winding!)
+	 (let ((old-top (car *active-windings*)))
+	    ;;Remove it from the list first so it's not active during its
+	    ;;own exit.
+	    (set! *active-windings* (cdr *active-windings*))
+	    ((after-func old-top))))
+
+      (define (set-active-windings! new-ws)
+	 (unless (eq? new-ws *active-windings*)
+	    (let ((shared (shared-tail new-ws *active-windings*)))
+
+	       ;;Define the looping functions.
+	       ;;Exit the old list.  Do deeper ones last.  Don't do
+	       ;;any shared ones.
+	       (define (pop-many)
+		  (unless (eq? *active-windings* shared)
+		     (deactivate-top-winding!)
+		     (pop-many)))
+	       ;;Enter the new list.  Do deeper ones first so that the
+	       ;;deeper windings will already be active.  Don't do any
+	       ;;shared ones.
+	       (define (push-many new-ws)
+		  (unless (eq? new-ws shared)
+		     (push-many (cdr new-ws))
+		     (activate-winding! (car new-ws))))
+
+	       ;;Do it.
+	       (pop-many)
+	       (push-many new-ws))))
+
+      ;;The definitions themselves.
+      (eval
+	 `(define call-with-current-continuation 
+	     ;;It internally uses the built-in call/cc, so capture it.
+	     ,(let ((old-c/cc call-with-current-continuation))
+		 (lambda (func)
+		    ;;Use old call/cc to get the continuation.
+		    (old-c/cc 
+		       (lambda (continuation)
+			  ;;Call func with not the continuation itself
+			  ;;but a procedure that adjusts the active
+			  ;;windings to what they were when we made
+			  ;;this, and only then calls the
+			  ;;continuation.
+			  (func 
+			     (let ((current-ws *active-windings*))
+				(lambda (x)
+				   (set-active-windings! current-ws)
+				   (continuation x)))))))))
+	 outer-env)
+      ;;We can't just say "define (dynamic-wind before thunk after)"
+      ;;because the lambda it's defined to lives in this environment,
+      ;;not in the global environment.
+      (eval 
+	 `(define dynamic-wind
+	     ,(lambda (before thunk after)
+		 ;;Make a new winding
+		 (activate-winding! (make-winding before after))
+		 (let ((result (thunk)))
+		    ;;Get rid of the new winding.
+		    (deactivate-top-winding!)
+		    ;;The return value is that of thunk.
+		    result)))
+	 outer-env)))
+
+(define call/cc call-with-current-continuation)
+
 
 ;;;;; atom? and equal? written by a.k