[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_is_true (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 << 0)
#define FRAME_REWINDABLE_P(f) (SCM_SMOB_FLAGS(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_SMOB_DATA (w))
#define WINDER_DATA(w)  ((void *)SCM_SMOB_DATA_2 (w))

#define WINDER_F_EXPLICIT    (1 << 0)
#define WINDER_F_REWIND      (1 << 1)
#define WINDER_F_MARK        (1 << 2)
#define WINDER_EXPLICIT_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_EXPLICIT)
#define WINDER_REWIND_P(w)   (SCM_SMOB_FLAGS(w) & WINDER_F_REWIND)
#define WINDER_MARK_P(w)     (SCM_SMOB_FLAGS(w) & WINDER_F_MARK)

void
scm_frame_begin (scm_t_frame_flags flags)
{
  SCM f;
  SCM_NEWSMOB (f, tc16_frame, 0);
  if (flags & SCM_F_FRAME_REWINDABLE)
    SCM_SET_SMOB_FLAGS (f, FRAME_F_REWINDABLE);
  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 SCM_PACK (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_NEWSMOB2 (w, tc16_winder,	(scm_t_bits) proc, (scm_t_bits) data);
  if (flags & SCM_F_WIND_EXPLICITLY)
    SCM_SET_SMOB_FLAGS (w, WINDER_F_EXPLICIT);
  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,	(scm_t_bits) proc, (scm_t_bits) data);
  SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND);
  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,	(scm_t_bits) proc, SCM_UNPACK (data));
  SCM_SET_SMOB_FLAGS (w, fl | WINDER_F_MARK);
  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, (scm_t_bits) proc, SCM_UNPACK (data));
  SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND | WINDER_F_MARK);
  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_is_eq (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 (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 (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;
7888309b	101	SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)),
1e6808ea	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
f5710d53 MV	135	#define FRAME_F_REWINDABLE (1 << 0)
f5710d53 MV	136	#define FRAME_REWINDABLE_P(f) (SCM_SMOB_FLAGS(f) & FRAME_F_REWINDABLE)
4845bbae MV	137
4845bbae MV	138	static scm_t_bits tc16_winder;
14578fa4	139	#define WINDER_P(w) SCM_SMOB_PREDICATE (tc16_winder, (w))
f5710d53 MV	140	#define WINDER_PROC(w) ((void ()(void ))SCM_SMOB_DATA (w))
f5710d53 MV	141	#define WINDER_DATA(w) ((void *)SCM_SMOB_DATA_2 (w))
4845bbae	142
f5710d53 MV	143	#define WINDER_F_EXPLICIT (1 << 0)
	144	#define WINDER_F_REWIND (1 << 1)
	145	#define WINDER_F_MARK (1 << 2)
	146	#define WINDER_EXPLICIT_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_EXPLICIT)
	147	#define WINDER_REWIND_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_REWIND)
	148	#define WINDER_MARK_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_MARK)
4845bbae MV	149
4845bbae MV	150	void
0888de4f	151	scm_frame_begin (scm_t_frame_flags flags)
4845bbae MV	152	{
4845bbae MV	153	SCM f;
f5710d53 MV	154	SCM_NEWSMOB (f, tc16_frame, 0);
	155	if (flags & SCM_F_FRAME_REWINDABLE)
	156	SCM_SET_SMOB_FLAGS (f, FRAME_F_REWINDABLE);
4845bbae MV	157	scm_dynwinds = scm_cons (f, scm_dynwinds);
	158	}
	159
	160	void
0888de4f	161	scm_frame_end (void)
4845bbae	162	{
0888de4f MV	163	/* Unwind upto and including the next frame entry. We can only
0888de4f MV	164	encounter #<winder> entries on the way.
4845bbae MV	165	*/
4845bbae MV	166
0888de4f	167	while (SCM_CONSP (scm_dynwinds))
4845bbae	168	{
0888de4f MV	169	SCM entry = SCM_CAR (scm_dynwinds);
	170	scm_dynwinds = SCM_CDR (scm_dynwinds);
	171
	172	if (FRAME_P (entry))
	173	return;
	174
	175	assert (WINDER_P (entry));
	176	if (!WINDER_REWIND_P (entry) && WINDER_EXPLICIT_P (entry))
	177	WINDER_PROC(entry) (WINDER_DATA (entry));
4845bbae MV	178	}
	179
	180	assert (0);
	181	}
	182
a520e4f0 MV	183	static SCM
	184	winder_mark (SCM w)
	185	{
	186	if (WINDER_MARK_P (w))
78addfa3	187	return SCM_PACK (WINDER_DATA (w));
a520e4f0 MV	188	return SCM_BOOL_F;
	189	}
	190
4845bbae	191	void
16c5cac2 MV	192	scm_frame_unwind_handler (void (proc) (void ), void *data,
16c5cac2 MV	193	scm_t_wind_flags flags)
4845bbae MV	194	{
4845bbae MV	195	SCM w;
f5710d53 MV	196	SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
	197	if (flags & SCM_F_WIND_EXPLICITLY)
	198	SCM_SET_SMOB_FLAGS (w, WINDER_F_EXPLICIT);
4845bbae MV	199	scm_dynwinds = scm_cons (w, scm_dynwinds);
	200	}
	201
	202	void
16c5cac2 MV	203	scm_frame_rewind_handler (void (proc) (void ), void *data,
16c5cac2 MV	204	scm_t_wind_flags flags)
4845bbae MV	205	{
4845bbae MV	206	SCM w;
f5710d53 MV	207	SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
f5710d53 MV	208	SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND);
4845bbae	209	scm_dynwinds = scm_cons (w, scm_dynwinds);
a520e4f0 MV	210	if (flags & SCM_F_WIND_EXPLICITLY)
	211	proc (data);
	212	}
	213
	214	void
16c5cac2 MV	215	scm_frame_unwind_handler_with_scm (void (*proc) (SCM), SCM data,
16c5cac2 MV	216	scm_t_wind_flags flags)
a520e4f0 MV	217	{
	218	SCM w;
	219	scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
f5710d53 MV	220	SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
f5710d53 MV	221	SCM_SET_SMOB_FLAGS (w, fl \| WINDER_F_MARK);
a520e4f0 MV	222	scm_dynwinds = scm_cons (w, scm_dynwinds);
	223	}
	224
	225	void
16c5cac2 MV	226	scm_frame_rewind_handler_with_scm (void (*proc) (SCM), SCM data,
16c5cac2 MV	227	scm_t_wind_flags flags)
a520e4f0 MV	228	{
a520e4f0 MV	229	SCM w;
f5710d53 MV	230	SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
f5710d53 MV	231	SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND \| WINDER_F_MARK);
a520e4f0 MV	232	scm_dynwinds = scm_cons (w, scm_dynwinds);
a520e4f0 MV	233	if (flags & SCM_F_WIND_EXPLICITLY)
4845bbae MV	234	proc (data);
	235	}
	236
c2654ef0	237	#ifdef GUILE_DEBUG
a1ec6916	238	SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
1bbd0b84	239	(),
156149ad MG	240	"Return the current wind chain. The wind chain contains all\n"
	241	"information required by @code{dynamic-wind} to call its\n"
	242	"argument thunks when entering/exiting its scope.")
1bbd0b84	243	#define FUNC_NAME s_scm_wind_chain
c2654ef0 MD	244	{
	245	return scm_dynwinds;
	246	}
1bbd0b84	247	#undef FUNC_NAME
c2654ef0 MD	248	#endif
c2654ef0 MD	249
2e171178	250	void
904a077d	251	scm_swap_bindings (SCM vars, SCM vals)
6778caf9 MD	252	{
	253	SCM tmp;
	254	while (SCM_NIMP (vals))
	255	{
904a077d MV	256	tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
904a077d MV	257	SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
6778caf9	258	SCM_SETCAR (vals, tmp);
904a077d	259	vars = SCM_CDR (vars);
6778caf9 MD	260	vals = SCM_CDR (vals);
	261	}
	262	}
c2654ef0	263
4845bbae	264	void
c014a02e	265	scm_dowinds (SCM to, long delta)
4845bbae	266	{
14578fa4	267	scm_i_dowinds (to, delta, NULL, NULL);
4845bbae MV	268	}
	269
	270	void
14578fa4	271	scm_i_dowinds (SCM to, long delta, void (turn_func) (void ), void *data)
0f2d19dd JB	272	{
0f2d19dd JB	273	tail:
bc36d050	274	if (scm_is_eq (to, scm_dynwinds))
4845bbae MV	275	{
	276	if (turn_func)
	277	turn_func (data);
	278	}
1be6b49c	279	else if (delta < 0)
0f2d19dd JB	280	{
	281	SCM wind_elt;
	282	SCM wind_key;
	283
14578fa4	284	scm_i_dowinds (SCM_CDR (to), 1 + delta, turn_func, data);
0f2d19dd	285	wind_elt = SCM_CAR (to);
4845bbae	286
928e0f42	287	if (FRAME_P (wind_elt))
0f2d19dd	288	{
928e0f42 MV	289	if (!FRAME_REWINDABLE_P (wind_elt))
	290	scm_misc_error ("dowinds",
	291	"cannot invoke continuation from this context",
	292	SCM_EOL);
	293	}
	294	else if (WINDER_P (wind_elt))
	295	{
	296	if (WINDER_REWIND_P (wind_elt))
	297	WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
0f2d19dd JB	298	}
0f2d19dd JB	299	else
0f2d19dd	300	{
928e0f42 MV	301	wind_key = SCM_CAR (wind_elt);
	302	/* key = #t \| symbol \| thunk \| list of variables */
	303	if (SCM_NIMP (wind_key))
4845bbae	304	{
928e0f42	305	if (SCM_CONSP (wind_key))
4845bbae	306	{
928e0f42 MV	307	if (SCM_VARIABLEP (SCM_CAR (wind_key)))
928e0f42 MV	308	scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
904a077d	309	}
928e0f42 MV	310	else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
928e0f42 MV	311	scm_call_0 (wind_key);
b3460a50	312	}
0f2d19dd	313	}
928e0f42	314
0f2d19dd JB	315	scm_dynwinds = to;
	316	}
	317	else
	318	{
0f2d19dd JB	319	SCM wind_elt;
	320	SCM wind_key;
	321
0f2d19dd JB	322	wind_elt = SCM_CAR (scm_dynwinds);
0f2d19dd JB	323	scm_dynwinds = SCM_CDR (scm_dynwinds);
4845bbae	324
928e0f42	325	if (FRAME_P (wind_elt))
0f2d19dd	326	{
928e0f42 MV	327	/* Nothing to do. */
	328	}
	329	else if (WINDER_P (wind_elt))
	330	{
	331	if (!WINDER_REWIND_P (wind_elt))
	332	WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
0f2d19dd JB	333	}
0f2d19dd JB	334	else
0f2d19dd	335	{
928e0f42 MV	336	wind_key = SCM_CAR (wind_elt);
928e0f42 MV	337	if (SCM_NIMP (wind_key))
4845bbae	338	{
928e0f42	339	if (SCM_CONSP (wind_key))
4845bbae	340	{
928e0f42 MV	341	if (SCM_VARIABLEP (SCM_CAR (wind_key)))
928e0f42 MV	342	scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
904a077d	343	}
928e0f42 MV	344	else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
928e0f42 MV	345	scm_call_0 (SCM_CDR (wind_elt));
b3460a50	346	}
0f2d19dd	347	}
928e0f42	348
0f2d19dd JB	349	delta--;
	350	goto tail; /* scm_dowinds(to, delta-1); */
	351	}
	352	}
	353
0f2d19dd JB	354	void
0f2d19dd JB	355	scm_init_dynwind ()
0f2d19dd	356	{
4845bbae	357	tc16_frame = scm_make_smob_type ("frame", 0);
4845bbae MV	358
4845bbae MV	359	tc16_winder = scm_make_smob_type ("winder", 0);
a520e4f0	360	scm_set_smob_mark (tc16_winder, winder_mark);
4845bbae	361
a0599745	362	#include "libguile/dynwind.x"
0f2d19dd	363	}
89e00824 ML	364
	365	/*
	366	Local Variables:
	367	c-file-style: "gnu"
	368	End:
	369	*/