[bpt/guile.git] / libguile / dynwind.c

/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004 Free Software Foundation, Inc.
 * 
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
 */


\f

#include <assert.h>

#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/alist.h"
#include "libguile/fluids.h"
#include "libguile/ports.h"
#include "libguile/smob.h"

#include "libguile/dynwind.h"
\f

/* {Dynamic wind}
 
   Things that can be on the wind list:

   #<frame>
   #<winder>
   (enter-proc . leave-proc)     dynamic-wind
   (tag . jmpbuf)                catch
   (tag . lazy-catch)            lazy-catch
     tag is either a symbol or a boolean

*/


SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
           (SCM in_guard, SCM thunk, SCM out_guard),
	    "All three arguments must be 0-argument procedures.\n"
	    "@var{in_guard} is called, then @var{thunk}, then\n"
	    "@var{out_guard}.\n"
	    "\n"
	    "If, any time during the execution of @var{thunk}, the\n"
	    "continuation of the @code{dynamic_wind} expression is escaped\n"
	    "non-locally, @var{out_guard} is called.  If the continuation of\n"
	    "the dynamic-wind is re-entered, @var{in_guard} is called.  Thus\n"
	    "@var{in_guard} and @var{out_guard} may be called any number of\n"
	    "times.\n"
	    "@lisp\n"
	    "(define x 'normal-binding)\n"
	    "@result{} x\n"
	    "(define a-cont  (call-with-current-continuation\n"
	    "		  (lambda (escape)\n"
	    "		     (let ((old-x x))\n"
	    "		       (dynamic-wind\n"
	    "			  ;; in-guard:\n"
	    "			  ;;\n"
	    "			  (lambda () (set! x 'special-binding))\n"
	    "\n"
	    "			  ;; thunk\n"
	    "			  ;;\n"
	    "		 	  (lambda () (display x) (newline)\n"
	    "				     (call-with-current-continuation escape)\n"
	    "				     (display x) (newline)\n"
	    "				     x)\n"
	    "\n"
	    "			  ;; out-guard:\n"
	    "			  ;;\n"
	    "			  (lambda () (set! x old-x)))))))\n"
	    "\n"
	    ";; Prints:\n"
	    "special-binding\n"
	    ";; Evaluates to:\n"
	    "@result{} a-cont\n"
	    "x\n"
	    "@result{} normal-binding\n"
	    "(a-cont #f)\n"
	    ";; Prints:\n"
	    "special-binding\n"
	    ";; Evaluates to:\n"
	    "@result{} a-cont  ;; the value of the (define a-cont...)\n"
	    "x\n"
	    "@result{} normal-binding\n"
	    "a-cont\n"
	    "@result{} special-binding\n"
	    "@end lisp")
#define FUNC_NAME s_scm_dynamic_wind
{
  SCM ans;
  SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (out_guard)),
	      out_guard,
	      SCM_ARG3, FUNC_NAME);
  scm_call_0 (in_guard);
  scm_dynwinds = scm_acons (in_guard, out_guard, scm_dynwinds);
  ans = scm_call_0 (thunk);
  scm_dynwinds = SCM_CDR (scm_dynwinds);
  scm_call_0 (out_guard);
  return ans;
}
#undef FUNC_NAME

SCM
scm_internal_dynamic_wind (scm_t_guard before,
			   scm_t_inner inner,
			   scm_t_guard after,
			   void *inner_data,
			   void *guard_data)
{
  SCM ans;

  scm_frame_begin (SCM_F_FRAME_REWINDABLE);
  scm_frame_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
  scm_frame_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
  ans = inner (inner_data);
  scm_frame_end ();
  return ans;
}

/* Frames and winders. */

static scm_t_bits tc16_frame;
#define FRAME_P(f)     SCM_SMOB_PREDICATE (tc16_frame, (f))

#define FRAME_F_REWINDABLE    (1 << 16)
#define FRAME_REWINDABLE_P(f) (SCM_CELL_WORD_0(f) & FRAME_F_REWINDABLE)

static scm_t_bits tc16_winder;
#define WINDER_P(w)     SCM_SMOB_PREDICATE (tc16_winder, (w))
#define WINDER_PROC(w)  ((void (*)(void *))SCM_CELL_WORD_1 (w))
#define WINDER_DATA(w)  ((void *)SCM_CELL_WORD_2 (w))

#define WINDER_F_EXPLICIT    (1 << 16)
#define WINDER_F_REWIND      (1 << 17)
#define WINDER_F_MARK        (1 << 18)
#define WINDER_EXPLICIT_P(w) (SCM_CELL_WORD_0(w) & WINDER_F_EXPLICIT)
#define WINDER_REWIND_P(w)   (SCM_CELL_WORD_0(w) & WINDER_F_REWIND)
#define WINDER_MARK_P(w)     (SCM_CELL_WORD_0(w) & WINDER_F_MARK)

void
scm_frame_begin (scm_t_frame_flags flags)
{
  SCM f;
  scm_t_bits fl = ((flags&SCM_F_FRAME_REWINDABLE)? FRAME_F_REWINDABLE : 0);
  SCM_NEWSMOB (f, tc16_frame | fl, 0);
  scm_dynwinds = scm_cons (f, scm_dynwinds);
}

void
scm_frame_end (void)
{
  /* Unwind upto and including the next frame entry.  We can only
     encounter #<winder> entries on the way.
   */

  while (SCM_CONSP (scm_dynwinds))
    {
      SCM entry = SCM_CAR (scm_dynwinds);
      scm_dynwinds = SCM_CDR (scm_dynwinds);

      if (FRAME_P (entry))
	return;

      assert (WINDER_P (entry));
      if (!WINDER_REWIND_P (entry) && WINDER_EXPLICIT_P (entry))
	WINDER_PROC(entry) (WINDER_DATA (entry));
    }

  assert (0);
}

static SCM
winder_mark (SCM w)
{
  if (WINDER_MARK_P (w))
    return WINDER_DATA (w);
  return SCM_BOOL_F;
}

void
scm_frame_unwind_handler (void (*proc) (void *), void *data,
			  scm_t_wind_flags flags)
{
  SCM w;
  scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
  SCM_NEWSMOB2 (w, tc16_winder | fl,
		(scm_t_bits) proc, (scm_t_bits) data);
  scm_dynwinds = scm_cons (w, scm_dynwinds);
}

void
scm_frame_rewind_handler (void (*proc) (void *), void *data,
			  scm_t_wind_flags flags)
{
  SCM w;
  SCM_NEWSMOB2 (w, tc16_winder | WINDER_F_REWIND,
		(scm_t_bits) proc, (scm_t_bits) data);
  scm_dynwinds = scm_cons (w, scm_dynwinds);
  if (flags & SCM_F_WIND_EXPLICITLY)
    proc (data);
}

void
scm_frame_unwind_handler_with_scm (void (*proc) (SCM), SCM data,
				   scm_t_wind_flags flags)
{
  SCM w;
  scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
  SCM_NEWSMOB2 (w, tc16_winder | fl | WINDER_F_MARK,
		(scm_t_bits) proc, SCM_UNPACK (data));
  scm_dynwinds = scm_cons (w, scm_dynwinds);
}

void
scm_frame_rewind_handler_with_scm (void (*proc) (SCM), SCM data,
				   scm_t_wind_flags flags)
{
  SCM w;
  SCM_NEWSMOB2 (w, tc16_winder | WINDER_F_REWIND | WINDER_F_MARK,
		(scm_t_bits) proc, SCM_UNPACK (data));
  scm_dynwinds = scm_cons (w, scm_dynwinds);
  if (flags & SCM_F_WIND_EXPLICITLY)
    proc (data);
}

#ifdef GUILE_DEBUG
SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0, 
            (),
	    "Return the current wind chain. The wind chain contains all\n"
	    "information required by @code{dynamic-wind} to call its\n"
	    "argument thunks when entering/exiting its scope.")
#define FUNC_NAME s_scm_wind_chain
{
  return scm_dynwinds;
}
#undef FUNC_NAME
#endif

void
scm_swap_bindings (SCM vars, SCM vals)
{
  SCM tmp;
  while (SCM_NIMP (vals))
    {
      tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
      SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
      SCM_SETCAR (vals, tmp);
      vars = SCM_CDR (vars);
      vals = SCM_CDR (vals);
    }
}

void
scm_dowinds (SCM to, long delta)
{
  scm_i_dowinds (to, delta, NULL, NULL);
}

void 
scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
{
 tail:
  if (SCM_EQ_P (to, scm_dynwinds))
    {
      if (turn_func)
	turn_func (data);
    }
  else if (delta < 0)
    {
      SCM wind_elt;
      SCM wind_key;

      scm_i_dowinds (SCM_CDR (to), 1 + delta, turn_func, data);
      wind_elt = SCM_CAR (to);

#if 0
      if (SCM_INUMP (wind_elt))
	{
	  scm_cross_dynwind_binding_scope (wind_elt, 0);
	}
      else
#endif
	{
	  if (FRAME_P (wind_elt))
	    {
	      if (!FRAME_REWINDABLE_P (wind_elt))
		scm_misc_error ("dowinds", 
				"cannot invoke continuation from this context",
				SCM_EOL);
	    }
	  else if (WINDER_P (wind_elt))
	    {
	      if (WINDER_REWIND_P (wind_elt))
		WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
	    }
	  else
	    {
	      wind_key = SCM_CAR (wind_elt);
	      /* key = #t | symbol | thunk | list of variables */
	      if (SCM_NIMP (wind_key))
		{
		  if (SCM_CONSP (wind_key))
		    {
		      if (SCM_VARIABLEP (SCM_CAR (wind_key)))
			scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
		    }
		  else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
		    scm_call_0 (wind_key);
		}
	    }
	}
      scm_dynwinds = to;
    }
  else
    {
      SCM wind_elt;
      SCM wind_key;

      wind_elt = SCM_CAR (scm_dynwinds);
      scm_dynwinds = SCM_CDR (scm_dynwinds);

#if 0
      if (SCM_INUMP (wind_elt))
	{
	  scm_cross_dynwind_binding_scope (wind_elt, 0);
	}
      else
#endif
	{
	  if (FRAME_P (wind_elt))
	    {
	      /* Nothing to do. */
	    }
	  else if (WINDER_P (wind_elt))
	    {
	      if (!WINDER_REWIND_P (wind_elt))
		WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
	    }
	  else
	    {
	      wind_key = SCM_CAR (wind_elt);
	      if (SCM_NIMP (wind_key))
		{
		  if (SCM_CONSP (wind_key))
		    {
		      if (SCM_VARIABLEP (SCM_CAR (wind_key)))
			scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
		    }
		  else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
		    scm_call_0 (SCM_CDR (wind_elt));
		}
	    }
	}
      delta--;
      goto tail;		/* scm_dowinds(to, delta-1); */
    }
}

void
scm_init_dynwind ()
{
  tc16_frame = scm_make_smob_type ("frame", 0);

  tc16_winder = scm_make_smob_type ("winder", 0);
  scm_set_smob_mark (tc16_winder, winder_mark);

#include "libguile/dynwind.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/
Commit	Line	Data
4845bbae	1	/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004 Free Software Foundation, Inc.
0f2d19dd	2	*
73be1d9e MV	3	* This library is free software; you can redistribute it and/or
	4	* modify it under the terms of the GNU Lesser General Public
	5	* License as published by the Free Software Foundation; either
	6	* version 2.1 of the License, or (at your option) any later version.
0f2d19dd	7	*
73be1d9e MV	8	* This library is distributed in the hope that it will be useful,
	9	* but WITHOUT ANY WARRANTY; without even the implied warranty of
	10	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	11	* Lesser General Public License for more details.
0f2d19dd	12	*
73be1d9e MV	13	* You should have received a copy of the GNU Lesser General Public
	14	* License along with this library; if not, write to the Free Software
	15	* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	16	*/
1bbd0b84	17
1bbd0b84	18
0f2d19dd JB	19	\f
0f2d19dd JB	20
4845bbae MV	21	#include <assert.h>
4845bbae MV	22
a0599745 MD	23	#include "libguile/_scm.h"
	24	#include "libguile/eval.h"
	25	#include "libguile/alist.h"
	26	#include "libguile/fluids.h"
	27	#include "libguile/ports.h"
	28	#include "libguile/smob.h"
0f2d19dd	29
a0599745	30	#include "libguile/dynwind.h"
0f2d19dd JB	31	\f
	32
	33	/* {Dynamic wind}
b3460a50 MV	34
	35	Things that can be on the wind list:
	36
4845bbae MV	37	#<frame>
4845bbae MV	38	#<winder>
b3460a50 MV	39	(enter-proc . leave-proc) dynamic-wind
	40	(tag . jmpbuf) catch
	41	(tag . lazy-catch) lazy-catch
	42	tag is either a symbol or a boolean
	43
b3460a50	44	*/
0f2d19dd JB	45
	46
	47
3b3b36dd	48	SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
1e6808ea MG	49	(SCM in_guard, SCM thunk, SCM out_guard),
	50	"All three arguments must be 0-argument procedures.\n"
	51	"@var{in_guard} is called, then @var{thunk}, then\n"
	52	"@var{out_guard}.\n"
	53	"\n"
	54	"If, any time during the execution of @var{thunk}, the\n"
	55	"continuation of the @code{dynamic_wind} expression is escaped\n"
	56	"non-locally, @var{out_guard} is called. If the continuation of\n"
	57	"the dynamic-wind is re-entered, @var{in_guard} is called. Thus\n"
	58	"@var{in_guard} and @var{out_guard} may be called any number of\n"
	59	"times.\n"
	60	"@lisp\n"
b380b885	61	"(define x 'normal-binding)\n"
1e6808ea	62	"@result{} x\n"
9401323e	63	"(define a-cont (call-with-current-continuation\n"
b380b885 MD	64	" (lambda (escape)\n"
	65	" (let ((old-x x))\n"
	66	" (dynamic-wind\n"
	67	" ;; in-guard:\n"
	68	" ;;\n"
1e6808ea MG	69	" (lambda () (set! x 'special-binding))\n"
1e6808ea MG	70	"\n"
b380b885 MD	71	" ;; thunk\n"
	72	" ;;\n"
	73	" (lambda () (display x) (newline)\n"
	74	" (call-with-current-continuation escape)\n"
	75	" (display x) (newline)\n"
1e6808ea MG	76	" x)\n"
1e6808ea MG	77	"\n"
b380b885 MD	78	" ;; out-guard:\n"
b380b885 MD	79	" ;;\n"
1e6808ea MG	80	" (lambda () (set! x old-x)))))))\n"
1e6808ea MG	81	"\n"
9401323e	82	";; Prints:\n"
b380b885 MD	83	"special-binding\n"
b380b885 MD	84	";; Evaluates to:\n"
1e6808ea	85	"@result{} a-cont\n"
b380b885	86	"x\n"
1e6808ea	87	"@result{} normal-binding\n"
b380b885 MD	88	"(a-cont #f)\n"
	89	";; Prints:\n"
	90	"special-binding\n"
	91	";; Evaluates to:\n"
1e6808ea	92	"@result{} a-cont ;; the value of the (define a-cont...)\n"
b380b885	93	"x\n"
1e6808ea	94	"@result{} normal-binding\n"
b380b885 MD	95	"a-cont\n"
b380b885 MD	96	"@result{} special-binding\n"
1e6808ea	97	"@end lisp")
1bbd0b84	98	#define FUNC_NAME s_scm_dynamic_wind
0f2d19dd JB	99	{
0f2d19dd JB	100	SCM ans;
1e6808ea MG	101	SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (out_guard)),
1e6808ea MG	102	out_guard,
1bbd0b84	103	SCM_ARG3, FUNC_NAME);
fdc28395	104	scm_call_0 (in_guard);
1e6808ea	105	scm_dynwinds = scm_acons (in_guard, out_guard, scm_dynwinds);
fdc28395	106	ans = scm_call_0 (thunk);
0f2d19dd	107	scm_dynwinds = SCM_CDR (scm_dynwinds);
fdc28395	108	scm_call_0 (out_guard);
0f2d19dd JB	109	return ans;
0f2d19dd JB	110	}
1bbd0b84	111	#undef FUNC_NAME
0f2d19dd	112
3346a90f	113	SCM
92c2555f MV	114	scm_internal_dynamic_wind (scm_t_guard before,
	115	scm_t_inner inner,
	116	scm_t_guard after,
3346a90f MD	117	void *inner_data,
	118	void *guard_data)
	119	{
4845bbae MV	120	SCM ans;
4845bbae MV	121
0888de4f	122	scm_frame_begin (SCM_F_FRAME_REWINDABLE);
16c5cac2 MV	123	scm_frame_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
16c5cac2 MV	124	scm_frame_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
3346a90f	125	ans = inner (inner_data);
0888de4f	126	scm_frame_end ();
3346a90f MD	127	return ans;
3346a90f MD	128	}
1cc91f1b	129
4845bbae MV	130	/* Frames and winders. */
	131
	132	static scm_t_bits tc16_frame;
	133	#define FRAME_P(f) SCM_SMOB_PREDICATE (tc16_frame, (f))
	134
	135	#define FRAME_F_REWINDABLE (1 << 16)
	136	#define FRAME_REWINDABLE_P(f) (SCM_CELL_WORD_0(f) & FRAME_F_REWINDABLE)
	137
	138	static scm_t_bits tc16_winder;
14578fa4 MV	139	#define WINDER_P(w) SCM_SMOB_PREDICATE (tc16_winder, (w))
	140	#define WINDER_PROC(w) ((void ()(void ))SCM_CELL_WORD_1 (w))
	141	#define WINDER_DATA(w) ((void *)SCM_CELL_WORD_2 (w))
4845bbae MV	142
	143	#define WINDER_F_EXPLICIT (1 << 16)
	144	#define WINDER_F_REWIND (1 << 17)
a520e4f0	145	#define WINDER_F_MARK (1 << 18)
4845bbae MV	146	#define WINDER_EXPLICIT_P(w) (SCM_CELL_WORD_0(w) & WINDER_F_EXPLICIT)
4845bbae MV	147	#define WINDER_REWIND_P(w) (SCM_CELL_WORD_0(w) & WINDER_F_REWIND)
a520e4f0	148	#define WINDER_MARK_P(w) (SCM_CELL_WORD_0(w) & WINDER_F_MARK)
4845bbae MV	149
4845bbae MV	150	void
0888de4f	151	scm_frame_begin (scm_t_frame_flags flags)
4845bbae MV	152	{
	153	SCM f;
	154	scm_t_bits fl = ((flags&SCM_F_FRAME_REWINDABLE)? FRAME_F_REWINDABLE : 0);
	155	SCM_NEWSMOB (f, tc16_frame \| fl, 0);
	156	scm_dynwinds = scm_cons (f, scm_dynwinds);
	157	}
	158
	159	void
0888de4f	160	scm_frame_end (void)
4845bbae	161	{
0888de4f MV	162	/* Unwind upto and including the next frame entry. We can only
0888de4f MV	163	encounter #<winder> entries on the way.
4845bbae MV	164	*/
4845bbae MV	165
0888de4f	166	while (SCM_CONSP (scm_dynwinds))
4845bbae	167	{
0888de4f MV	168	SCM entry = SCM_CAR (scm_dynwinds);
	169	scm_dynwinds = SCM_CDR (scm_dynwinds);
	170
	171	if (FRAME_P (entry))
	172	return;
	173
	174	assert (WINDER_P (entry));
	175	if (!WINDER_REWIND_P (entry) && WINDER_EXPLICIT_P (entry))
	176	WINDER_PROC(entry) (WINDER_DATA (entry));
4845bbae MV	177	}
	178
	179	assert (0);
	180	}
	181
a520e4f0 MV	182	static SCM
	183	winder_mark (SCM w)
	184	{
	185	if (WINDER_MARK_P (w))
	186	return WINDER_DATA (w);
	187	return SCM_BOOL_F;
	188	}
	189
4845bbae	190	void
16c5cac2 MV	191	scm_frame_unwind_handler (void (proc) (void ), void *data,
16c5cac2 MV	192	scm_t_wind_flags flags)
4845bbae MV	193	{
4845bbae MV	194	SCM w;
a520e4f0	195	scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
4845bbae MV	196	SCM_NEWSMOB2 (w, tc16_winder \| fl,
	197	(scm_t_bits) proc, (scm_t_bits) data);
	198	scm_dynwinds = scm_cons (w, scm_dynwinds);
	199	}
	200
	201	void
16c5cac2 MV	202	scm_frame_rewind_handler (void (proc) (void ), void *data,
16c5cac2 MV	203	scm_t_wind_flags flags)
4845bbae MV	204	{
	205	SCM w;
	206	SCM_NEWSMOB2 (w, tc16_winder \| WINDER_F_REWIND,
	207	(scm_t_bits) proc, (scm_t_bits) data);
	208	scm_dynwinds = scm_cons (w, scm_dynwinds);
a520e4f0 MV	209	if (flags & SCM_F_WIND_EXPLICITLY)
	210	proc (data);
	211	}
	212
	213	void
16c5cac2 MV	214	scm_frame_unwind_handler_with_scm (void (*proc) (SCM), SCM data,
16c5cac2 MV	215	scm_t_wind_flags flags)
a520e4f0 MV	216	{
	217	SCM w;
	218	scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
	219	SCM_NEWSMOB2 (w, tc16_winder \| fl \| WINDER_F_MARK,
	220	(scm_t_bits) proc, SCM_UNPACK (data));
	221	scm_dynwinds = scm_cons (w, scm_dynwinds);
	222	}
	223
	224	void
16c5cac2 MV	225	scm_frame_rewind_handler_with_scm (void (*proc) (SCM), SCM data,
16c5cac2 MV	226	scm_t_wind_flags flags)
a520e4f0 MV	227	{
	228	SCM w;
	229	SCM_NEWSMOB2 (w, tc16_winder \| WINDER_F_REWIND \| WINDER_F_MARK,
	230	(scm_t_bits) proc, SCM_UNPACK (data));
	231	scm_dynwinds = scm_cons (w, scm_dynwinds);
	232	if (flags & SCM_F_WIND_EXPLICITLY)
4845bbae MV	233	proc (data);
	234	}
	235
c2654ef0	236	#ifdef GUILE_DEBUG
a1ec6916	237	SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
1bbd0b84	238	(),
156149ad MG	239	"Return the current wind chain. The wind chain contains all\n"
	240	"information required by @code{dynamic-wind} to call its\n"
	241	"argument thunks when entering/exiting its scope.")
1bbd0b84	242	#define FUNC_NAME s_scm_wind_chain
c2654ef0 MD	243	{
	244	return scm_dynwinds;
	245	}
1bbd0b84	246	#undef FUNC_NAME
c2654ef0 MD	247	#endif
c2654ef0 MD	248
2e171178	249	void
904a077d	250	scm_swap_bindings (SCM vars, SCM vals)
6778caf9 MD	251	{
	252	SCM tmp;
	253	while (SCM_NIMP (vals))
	254	{
904a077d MV	255	tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
904a077d MV	256	SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
6778caf9	257	SCM_SETCAR (vals, tmp);
904a077d	258	vars = SCM_CDR (vars);
6778caf9 MD	259	vals = SCM_CDR (vals);
	260	}
	261	}
c2654ef0	262
4845bbae	263	void
c014a02e	264	scm_dowinds (SCM to, long delta)
4845bbae	265	{
14578fa4	266	scm_i_dowinds (to, delta, NULL, NULL);
4845bbae MV	267	}
	268
	269	void
14578fa4	270	scm_i_dowinds (SCM to, long delta, void (turn_func) (void ), void *data)
0f2d19dd JB	271	{
0f2d19dd JB	272	tail:
4845bbae MV	273	if (SCM_EQ_P (to, scm_dynwinds))
	274	{
	275	if (turn_func)
	276	turn_func (data);
	277	}
1be6b49c	278	else if (delta < 0)
0f2d19dd JB	279	{
	280	SCM wind_elt;
	281	SCM wind_key;
	282
14578fa4	283	scm_i_dowinds (SCM_CDR (to), 1 + delta, turn_func, data);
0f2d19dd	284	wind_elt = SCM_CAR (to);
4845bbae	285
0f2d19dd JB	286	#if 0
	287	if (SCM_INUMP (wind_elt))
	288	{
	289	scm_cross_dynwind_binding_scope (wind_elt, 0);
	290	}
	291	else
	292	#endif
	293	{
4845bbae	294	if (FRAME_P (wind_elt))
b3460a50	295	{
4845bbae MV	296	if (!FRAME_REWINDABLE_P (wind_elt))
	297	scm_misc_error ("dowinds",
	298	"cannot invoke continuation from this context",
	299	SCM_EOL);
	300	}
	301	else if (WINDER_P (wind_elt))
	302	{
	303	if (WINDER_REWIND_P (wind_elt))
14578fa4	304	WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
4845bbae MV	305	}
	306	else
	307	{
	308	wind_key = SCM_CAR (wind_elt);
540cc7ab	309	/* key = #t \| symbol \| thunk \| list of variables */
4845bbae MV	310	if (SCM_NIMP (wind_key))
	311	{
	312	if (SCM_CONSP (wind_key))
	313	{
	314	if (SCM_VARIABLEP (SCM_CAR (wind_key)))
	315	scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
4845bbae MV	316	}
	317	else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
	318	scm_call_0 (wind_key);
904a077d	319	}
b3460a50	320	}
0f2d19dd JB	321	}
	322	scm_dynwinds = to;
	323	}
	324	else
	325	{
0f2d19dd JB	326	SCM wind_elt;
	327	SCM wind_key;
	328
0f2d19dd JB	329	wind_elt = SCM_CAR (scm_dynwinds);
0f2d19dd JB	330	scm_dynwinds = SCM_CDR (scm_dynwinds);
4845bbae	331
0f2d19dd JB	332	#if 0
	333	if (SCM_INUMP (wind_elt))
	334	{
	335	scm_cross_dynwind_binding_scope (wind_elt, 0);
	336	}
	337	else
	338	#endif
	339	{
4845bbae MV	340	if (FRAME_P (wind_elt))
	341	{
	342	/* Nothing to do. */
	343	}
	344	else if (WINDER_P (wind_elt))
b3460a50	345	{
14578fa4 MV	346	if (!WINDER_REWIND_P (wind_elt))
14578fa4 MV	347	WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
4845bbae MV	348	}
	349	else
	350	{
	351	wind_key = SCM_CAR (wind_elt);
	352	if (SCM_NIMP (wind_key))
	353	{
	354	if (SCM_CONSP (wind_key))
	355	{
	356	if (SCM_VARIABLEP (SCM_CAR (wind_key)))
	357	scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
4845bbae MV	358	}
	359	else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
	360	scm_call_0 (SCM_CDR (wind_elt));
904a077d	361	}
b3460a50	362	}
0f2d19dd JB	363	}
	364	delta--;
	365	goto tail; /* scm_dowinds(to, delta-1); */
	366	}
	367	}
	368
0f2d19dd JB	369	void
0f2d19dd JB	370	scm_init_dynwind ()
0f2d19dd	371	{
4845bbae	372	tc16_frame = scm_make_smob_type ("frame", 0);
4845bbae MV	373
4845bbae MV	374	tc16_winder = scm_make_smob_type ("winder", 0);
a520e4f0	375	scm_set_smob_mark (tc16_winder, winder_mark);
4845bbae	376
a0599745	377	#include "libguile/dynwind.x"
0f2d19dd	378	}
89e00824 ML	379
	380	/*
	381	Local Variables:
	382	c-file-style: "gnu"
	383	End:
	384	*/