[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

   ((fluid ...) . (value ...))   with-fluids

*/


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_begin_frame (SCM_F_FRAME_REWINDABLE);
  scm_on_rewind (before, guard_data, SCM_F_WIND_EXPLICITLY);
  scm_on_unwind (after, guard_data, SCM_F_WIND_EXPLICITLY);
  ans = inner (inner_data);
  scm_end_frame ();
  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_begin_frame (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_end_frame (void)
{
  long delta;
  SCM to;
  
  /* Unwind upto and including the next frame entry.
   */

  for (to = scm_dynwinds, delta = 1;
       SCM_CONSP (to);
       to = SCM_CDR (to), delta++)
    {
      if (FRAME_P (SCM_CAR (to)))
	{
	  scm_i_dowinds (SCM_CDR (to), delta, 1, NULL, NULL);
	  return;
	}
    }

  assert (0);
}

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

void
scm_on_unwind (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_on_rewind (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_on_unwind_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_on_rewind_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, 0, NULL, NULL);
}

void 
scm_i_dowinds (SCM to, long delta, int explicit,
	       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, explicit,
		     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))
		{
		  void (*proc) (void *) = WINDER_PROC (wind_elt);
		  void *data = WINDER_DATA (wind_elt);
		  proc (data);
		}
	    }
	  else
	    {
	      wind_key = SCM_CAR (wind_elt);
	      /* key = #t | symbol | thunk | list of variables | list of fluids */
	      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_FLUIDP (SCM_CAR (wind_key)))
			scm_i_swap_fluids (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)
		  && (!explicit || WINDER_EXPLICIT_P (wind_elt)))
		{
		  void (*proc) (void *) = WINDER_PROC (wind_elt);
		  void *data = WINDER_DATA (wind_elt);
		  proc (data);
		}
	    }
	  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_FLUIDP (SCM_CAR (wind_key)))
			scm_i_swap_fluids_reverse (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
	44	((fluid ...) . (value ...)) with-fluids
	45
	46	*/
0f2d19dd JB	47
	48
	49
3b3b36dd	50	SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
1e6808ea MG	51	(SCM in_guard, SCM thunk, SCM out_guard),
	52	"All three arguments must be 0-argument procedures.\n"
	53	"@var{in_guard} is called, then @var{thunk}, then\n"
	54	"@var{out_guard}.\n"
	55	"\n"
	56	"If, any time during the execution of @var{thunk}, the\n"
	57	"continuation of the @code{dynamic_wind} expression is escaped\n"
	58	"non-locally, @var{out_guard} is called. If the continuation of\n"
	59	"the dynamic-wind is re-entered, @var{in_guard} is called. Thus\n"
	60	"@var{in_guard} and @var{out_guard} may be called any number of\n"
	61	"times.\n"
	62	"@lisp\n"
b380b885	63	"(define x 'normal-binding)\n"
1e6808ea	64	"@result{} x\n"
9401323e	65	"(define a-cont (call-with-current-continuation\n"
b380b885 MD	66	" (lambda (escape)\n"
	67	" (let ((old-x x))\n"
	68	" (dynamic-wind\n"
	69	" ;; in-guard:\n"
	70	" ;;\n"
1e6808ea MG	71	" (lambda () (set! x 'special-binding))\n"
1e6808ea MG	72	"\n"
b380b885 MD	73	" ;; thunk\n"
	74	" ;;\n"
	75	" (lambda () (display x) (newline)\n"
	76	" (call-with-current-continuation escape)\n"
	77	" (display x) (newline)\n"
1e6808ea MG	78	" x)\n"
1e6808ea MG	79	"\n"
b380b885 MD	80	" ;; out-guard:\n"
b380b885 MD	81	" ;;\n"
1e6808ea MG	82	" (lambda () (set! x old-x)))))))\n"
1e6808ea MG	83	"\n"
9401323e	84	";; Prints:\n"
b380b885 MD	85	"special-binding\n"
b380b885 MD	86	";; Evaluates to:\n"
1e6808ea	87	"@result{} a-cont\n"
b380b885	88	"x\n"
1e6808ea	89	"@result{} normal-binding\n"
b380b885 MD	90	"(a-cont #f)\n"
	91	";; Prints:\n"
	92	"special-binding\n"
	93	";; Evaluates to:\n"
1e6808ea	94	"@result{} a-cont ;; the value of the (define a-cont...)\n"
b380b885	95	"x\n"
1e6808ea	96	"@result{} normal-binding\n"
b380b885 MD	97	"a-cont\n"
b380b885 MD	98	"@result{} special-binding\n"
1e6808ea	99	"@end lisp")
1bbd0b84	100	#define FUNC_NAME s_scm_dynamic_wind
0f2d19dd JB	101	{
0f2d19dd JB	102	SCM ans;
1e6808ea MG	103	SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (out_guard)),
1e6808ea MG	104	out_guard,
1bbd0b84	105	SCM_ARG3, FUNC_NAME);
fdc28395	106	scm_call_0 (in_guard);
1e6808ea	107	scm_dynwinds = scm_acons (in_guard, out_guard, scm_dynwinds);
fdc28395	108	ans = scm_call_0 (thunk);
0f2d19dd	109	scm_dynwinds = SCM_CDR (scm_dynwinds);
fdc28395	110	scm_call_0 (out_guard);
0f2d19dd JB	111	return ans;
0f2d19dd JB	112	}
1bbd0b84	113	#undef FUNC_NAME
0f2d19dd	114
3346a90f	115	SCM
92c2555f MV	116	scm_internal_dynamic_wind (scm_t_guard before,
	117	scm_t_inner inner,
	118	scm_t_guard after,
3346a90f MD	119	void *inner_data,
	120	void *guard_data)
	121	{
4845bbae MV	122	SCM ans;
	123
	124	scm_begin_frame (SCM_F_FRAME_REWINDABLE);
a520e4f0 MV	125	scm_on_rewind (before, guard_data, SCM_F_WIND_EXPLICITLY);
a520e4f0 MV	126	scm_on_unwind (after, guard_data, SCM_F_WIND_EXPLICITLY);
3346a90f	127	ans = inner (inner_data);
4845bbae	128	scm_end_frame ();
3346a90f MD	129	return ans;
3346a90f MD	130	}
1cc91f1b	131
4845bbae MV	132	/* Frames and winders. */
	133
	134	static scm_t_bits tc16_frame;
	135	#define FRAME_P(f) SCM_SMOB_PREDICATE (tc16_frame, (f))
	136
	137	#define FRAME_F_REWINDABLE (1 << 16)
	138	#define FRAME_REWINDABLE_P(f) (SCM_CELL_WORD_0(f) & FRAME_F_REWINDABLE)
	139
	140	static scm_t_bits tc16_winder;
	141	#define WINDER_P(w) SCM_SMOB_PREDICATE (tc16_winder, (w))
	142	#define WINDER_PROC(w) ((void ()(void ))SCM_CELL_WORD_1 (w))
	143	#define WINDER_DATA(w) ((void *)SCM_CELL_WORD_2 (w))
	144
	145	#define WINDER_F_EXPLICIT (1 << 16)
	146	#define WINDER_F_REWIND (1 << 17)
a520e4f0	147	#define WINDER_F_MARK (1 << 18)
4845bbae MV	148	#define WINDER_EXPLICIT_P(w) (SCM_CELL_WORD_0(w) & WINDER_F_EXPLICIT)
4845bbae MV	149	#define WINDER_REWIND_P(w) (SCM_CELL_WORD_0(w) & WINDER_F_REWIND)
a520e4f0	150	#define WINDER_MARK_P(w) (SCM_CELL_WORD_0(w) & WINDER_F_MARK)
4845bbae MV	151
	152	void
	153	scm_begin_frame (scm_t_frame_flags flags)
	154	{
	155	SCM f;
	156	scm_t_bits fl = ((flags&SCM_F_FRAME_REWINDABLE)? FRAME_F_REWINDABLE : 0);
	157	SCM_NEWSMOB (f, tc16_frame \| fl, 0);
	158	scm_dynwinds = scm_cons (f, scm_dynwinds);
	159	}
	160
	161	void
	162	scm_end_frame (void)
	163	{
	164	long delta;
	165	SCM to;
	166
	167	/* Unwind upto and including the next frame entry.
	168	*/
	169
	170	for (to = scm_dynwinds, delta = 1;
	171	SCM_CONSP (to);
	172	to = SCM_CDR (to), delta++)
	173	{
	174	if (FRAME_P (SCM_CAR (to)))
	175	{
	176	scm_i_dowinds (SCM_CDR (to), delta, 1, NULL, NULL);
	177	return;
	178	}
	179	}
	180
	181	assert (0);
	182	}
	183
a520e4f0 MV	184	static SCM
	185	winder_mark (SCM w)
	186	{
	187	if (WINDER_MARK_P (w))
	188	return WINDER_DATA (w);
	189	return SCM_BOOL_F;
	190	}
	191
4845bbae MV	192	void
	193	scm_on_unwind (void (proc) (void ), void *data,
	194	scm_t_wind_flags flags)
	195	{
	196	SCM w;
a520e4f0	197	scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
4845bbae MV	198	SCM_NEWSMOB2 (w, tc16_winder \| fl,
	199	(scm_t_bits) proc, (scm_t_bits) data);
	200	scm_dynwinds = scm_cons (w, scm_dynwinds);
	201	}
	202
	203	void
	204	scm_on_rewind (void (proc) (void ), void *data,
	205	scm_t_wind_flags flags)
	206	{
	207	SCM w;
	208	SCM_NEWSMOB2 (w, tc16_winder \| WINDER_F_REWIND,
	209	(scm_t_bits) proc, (scm_t_bits) data);
	210	scm_dynwinds = scm_cons (w, scm_dynwinds);
a520e4f0 MV	211	if (flags & SCM_F_WIND_EXPLICITLY)
	212	proc (data);
	213	}
	214
	215	void
	216	scm_on_unwind_with_scm (void (*proc) (SCM), SCM data,
	217	scm_t_wind_flags flags)
	218	{
	219	SCM w;
	220	scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
	221	SCM_NEWSMOB2 (w, tc16_winder \| fl \| WINDER_F_MARK,
	222	(scm_t_bits) proc, SCM_UNPACK (data));
	223	scm_dynwinds = scm_cons (w, scm_dynwinds);
	224	}
	225
	226	void
	227	scm_on_rewind_with_scm (void (*proc) (SCM), SCM data,
	228	scm_t_wind_flags flags)
	229	{
	230	SCM w;
	231	SCM_NEWSMOB2 (w, tc16_winder \| WINDER_F_REWIND \| WINDER_F_MARK,
	232	(scm_t_bits) proc, SCM_UNPACK (data));
	233	scm_dynwinds = scm_cons (w, scm_dynwinds);
	234	if (flags & SCM_F_WIND_EXPLICITLY)
4845bbae MV	235	proc (data);
	236	}
	237
c2654ef0	238	#ifdef GUILE_DEBUG
a1ec6916	239	SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
1bbd0b84	240	(),
156149ad MG	241	"Return the current wind chain. The wind chain contains all\n"
	242	"information required by @code{dynamic-wind} to call its\n"
	243	"argument thunks when entering/exiting its scope.")
1bbd0b84	244	#define FUNC_NAME s_scm_wind_chain
c2654ef0 MD	245	{
	246	return scm_dynwinds;
	247	}
1bbd0b84	248	#undef FUNC_NAME
c2654ef0 MD	249	#endif
c2654ef0 MD	250
2e171178	251	void
904a077d	252	scm_swap_bindings (SCM vars, SCM vals)
6778caf9 MD	253	{
	254	SCM tmp;
	255	while (SCM_NIMP (vals))
	256	{
904a077d MV	257	tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
904a077d MV	258	SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
6778caf9	259	SCM_SETCAR (vals, tmp);
904a077d	260	vars = SCM_CDR (vars);
6778caf9 MD	261	vals = SCM_CDR (vals);
	262	}
	263	}
c2654ef0	264
4845bbae	265	void
c014a02e	266	scm_dowinds (SCM to, long delta)
4845bbae MV	267	{
	268	scm_i_dowinds (to, delta, 0, NULL, NULL);
	269	}
	270
	271	void
	272	scm_i_dowinds (SCM to, long delta, int explicit,
	273	void (turn_func) (void ), void *data)
0f2d19dd JB	274	{
0f2d19dd JB	275	tail:
4845bbae MV	276	if (SCM_EQ_P (to, scm_dynwinds))
	277	{
	278	if (turn_func)
	279	turn_func (data);
	280	}
1be6b49c	281	else if (delta < 0)
0f2d19dd JB	282	{
	283	SCM wind_elt;
	284	SCM wind_key;
	285
4845bbae MV	286	scm_i_dowinds (SCM_CDR (to), 1 + delta, explicit,
4845bbae MV	287	turn_func, data);
0f2d19dd	288	wind_elt = SCM_CAR (to);
4845bbae	289
0f2d19dd JB	290	#if 0
	291	if (SCM_INUMP (wind_elt))
	292	{
	293	scm_cross_dynwind_binding_scope (wind_elt, 0);
	294	}
	295	else
	296	#endif
	297	{
4845bbae	298	if (FRAME_P (wind_elt))
b3460a50	299	{
4845bbae MV	300	if (!FRAME_REWINDABLE_P (wind_elt))
	301	scm_misc_error ("dowinds",
	302	"cannot invoke continuation from this context",
	303	SCM_EOL);
	304	}
	305	else if (WINDER_P (wind_elt))
	306	{
	307	if (WINDER_REWIND_P (wind_elt))
904a077d	308	{
4845bbae MV	309	void (proc) (void ) = WINDER_PROC (wind_elt);
	310	void *data = WINDER_DATA (wind_elt);
	311	proc (data);
	312	}
	313	}
	314	else
	315	{
	316	wind_key = SCM_CAR (wind_elt);
	317	/* key = #t \| symbol \| thunk \| list of variables \| list of fluids */
	318	if (SCM_NIMP (wind_key))
	319	{
	320	if (SCM_CONSP (wind_key))
	321	{
	322	if (SCM_VARIABLEP (SCM_CAR (wind_key)))
	323	scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
	324	else if (SCM_FLUIDP (SCM_CAR (wind_key)))
a520e4f0	325	scm_i_swap_fluids (wind_key, SCM_CDR (wind_elt));
4845bbae MV	326	}
	327	else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
	328	scm_call_0 (wind_key);
904a077d	329	}
b3460a50	330	}
0f2d19dd JB	331	}
	332	scm_dynwinds = to;
	333	}
	334	else
	335	{
0f2d19dd JB	336	SCM wind_elt;
	337	SCM wind_key;
	338
0f2d19dd JB	339	wind_elt = SCM_CAR (scm_dynwinds);
0f2d19dd JB	340	scm_dynwinds = SCM_CDR (scm_dynwinds);
4845bbae	341
0f2d19dd JB	342	#if 0
	343	if (SCM_INUMP (wind_elt))
	344	{
	345	scm_cross_dynwind_binding_scope (wind_elt, 0);
	346	}
	347	else
	348	#endif
	349	{
4845bbae MV	350	if (FRAME_P (wind_elt))
	351	{
	352	/* Nothing to do. */
	353	}
	354	else if (WINDER_P (wind_elt))
b3460a50	355	{
4845bbae MV	356	if (!WINDER_REWIND_P (wind_elt)
4845bbae MV	357	&& (!explicit \|\| WINDER_EXPLICIT_P (wind_elt)))
904a077d	358	{
4845bbae MV	359	void (proc) (void ) = WINDER_PROC (wind_elt);
	360	void *data = WINDER_DATA (wind_elt);
	361	proc (data);
	362	}
	363	}
	364	else
	365	{
	366	wind_key = SCM_CAR (wind_elt);
	367	if (SCM_NIMP (wind_key))
	368	{
	369	if (SCM_CONSP (wind_key))
	370	{
	371	if (SCM_VARIABLEP (SCM_CAR (wind_key)))
	372	scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
	373	else if (SCM_FLUIDP (SCM_CAR (wind_key)))
a520e4f0 MV	374	scm_i_swap_fluids_reverse (wind_key,
a520e4f0 MV	375	SCM_CDR (wind_elt));
4845bbae MV	376	}
	377	else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
	378	scm_call_0 (SCM_CDR (wind_elt));
904a077d	379	}
b3460a50	380	}
0f2d19dd JB	381	}
	382	delta--;
	383	goto tail; /* scm_dowinds(to, delta-1); */
	384	}
	385	}
	386
0f2d19dd JB	387	void
0f2d19dd JB	388	scm_init_dynwind ()
0f2d19dd	389	{
4845bbae	390	tc16_frame = scm_make_smob_type ("frame", 0);
4845bbae MV	391
4845bbae MV	392	tc16_winder = scm_make_smob_type ("winder", 0);
a520e4f0	393	scm_set_smob_mark (tc16_winder, winder_mark);
4845bbae	394
a0599745	395	#include "libguile/dynwind.x"
0f2d19dd	396	}
89e00824 ML	397
	398	/*
	399	Local Variables:
	400	c-file-style: "gnu"
	401	End:
	402	*/