[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);
}

void
scm_frame_free (void *mem)
{
  scm_frame_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY);
}

#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
6d5649b7 MV	237	void
	238	scm_frame_free (void *mem)
	239	{
	240	scm_frame_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY);
	241	}
	242
c2654ef0	243	#ifdef GUILE_DEBUG
a1ec6916	244	SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
1bbd0b84	245	(),
156149ad MG	246	"Return the current wind chain. The wind chain contains all\n"
	247	"information required by @code{dynamic-wind} to call its\n"
	248	"argument thunks when entering/exiting its scope.")
1bbd0b84	249	#define FUNC_NAME s_scm_wind_chain
c2654ef0 MD	250	{
	251	return scm_dynwinds;
	252	}
1bbd0b84	253	#undef FUNC_NAME
c2654ef0 MD	254	#endif
c2654ef0 MD	255
2e171178	256	void
904a077d	257	scm_swap_bindings (SCM vars, SCM vals)
6778caf9 MD	258	{
	259	SCM tmp;
	260	while (SCM_NIMP (vals))
	261	{
904a077d MV	262	tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
904a077d MV	263	SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
6778caf9	264	SCM_SETCAR (vals, tmp);
904a077d	265	vars = SCM_CDR (vars);
6778caf9 MD	266	vals = SCM_CDR (vals);
	267	}
	268	}
c2654ef0	269
4845bbae	270	void
c014a02e	271	scm_dowinds (SCM to, long delta)
4845bbae	272	{
14578fa4	273	scm_i_dowinds (to, delta, NULL, NULL);
4845bbae MV	274	}
	275
	276	void
14578fa4	277	scm_i_dowinds (SCM to, long delta, void (turn_func) (void ), void *data)
0f2d19dd JB	278	{
0f2d19dd JB	279	tail:
bc36d050	280	if (scm_is_eq (to, scm_dynwinds))
4845bbae MV	281	{
	282	if (turn_func)
	283	turn_func (data);
	284	}
1be6b49c	285	else if (delta < 0)
0f2d19dd JB	286	{
	287	SCM wind_elt;
	288	SCM wind_key;
	289
14578fa4	290	scm_i_dowinds (SCM_CDR (to), 1 + delta, turn_func, data);
0f2d19dd	291	wind_elt = SCM_CAR (to);
4845bbae	292
928e0f42	293	if (FRAME_P (wind_elt))
0f2d19dd	294	{
928e0f42 MV	295	if (!FRAME_REWINDABLE_P (wind_elt))
	296	scm_misc_error ("dowinds",
	297	"cannot invoke continuation from this context",
	298	SCM_EOL);
	299	}
	300	else if (WINDER_P (wind_elt))
	301	{
	302	if (WINDER_REWIND_P (wind_elt))
	303	WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
0f2d19dd JB	304	}
0f2d19dd JB	305	else
0f2d19dd	306	{
928e0f42 MV	307	wind_key = SCM_CAR (wind_elt);
	308	/* key = #t \| symbol \| thunk \| list of variables */
	309	if (SCM_NIMP (wind_key))
4845bbae	310	{
928e0f42	311	if (SCM_CONSP (wind_key))
4845bbae	312	{
928e0f42 MV	313	if (SCM_VARIABLEP (SCM_CAR (wind_key)))
928e0f42 MV	314	scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
904a077d	315	}
928e0f42 MV	316	else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
928e0f42 MV	317	scm_call_0 (wind_key);
b3460a50	318	}
0f2d19dd	319	}
928e0f42	320
0f2d19dd JB	321	scm_dynwinds = to;
	322	}
	323	else
	324	{
0f2d19dd JB	325	SCM wind_elt;
	326	SCM wind_key;
	327
0f2d19dd JB	328	wind_elt = SCM_CAR (scm_dynwinds);
0f2d19dd JB	329	scm_dynwinds = SCM_CDR (scm_dynwinds);
4845bbae	330
928e0f42	331	if (FRAME_P (wind_elt))
0f2d19dd	332	{
928e0f42 MV	333	/* Nothing to do. */
	334	}
	335	else if (WINDER_P (wind_elt))
	336	{
	337	if (!WINDER_REWIND_P (wind_elt))
	338	WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
0f2d19dd JB	339	}
0f2d19dd JB	340	else
0f2d19dd	341	{
928e0f42 MV	342	wind_key = SCM_CAR (wind_elt);
928e0f42 MV	343	if (SCM_NIMP (wind_key))
4845bbae	344	{
928e0f42	345	if (SCM_CONSP (wind_key))
4845bbae	346	{
928e0f42 MV	347	if (SCM_VARIABLEP (SCM_CAR (wind_key)))
928e0f42 MV	348	scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
904a077d	349	}
928e0f42 MV	350	else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
928e0f42 MV	351	scm_call_0 (SCM_CDR (wind_elt));
b3460a50	352	}
0f2d19dd	353	}
928e0f42	354
0f2d19dd JB	355	delta--;
	356	goto tail; /* scm_dowinds(to, delta-1); */
	357	}
	358	}
	359
0f2d19dd JB	360	void
0f2d19dd JB	361	scm_init_dynwind ()
0f2d19dd	362	{
4845bbae	363	tc16_frame = scm_make_smob_type ("frame", 0);
4845bbae MV	364
4845bbae MV	365	tc16_winder = scm_make_smob_type ("winder", 0);
a520e4f0	366	scm_set_smob_mark (tc16_winder, winder_mark);
4845bbae	367
a0599745	368	#include "libguile/dynwind.x"
0f2d19dd	369	}
89e00824 ML	370
	371	/*
	372	Local Variables:
	373	c-file-style: "gnu"
	374	End:
	375	*/