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

/* Copyright (C) 1995,1996,1998,1999,2000,2001 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 "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:

   (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

/* The implementation of a C-callable dynamic-wind,
 * scm_internal_dynamic_wind, requires packaging of C pointers in a
 * smob.  Objects of this type are pushed onto the dynwind chain.
 */

#define SCM_GUARDSP(obj) SCM_TYP16_PREDICATE (tc16_guards, obj)
#define SCM_BEFORE_GUARD(obj) ((scm_t_guard) SCM_CELL_WORD (obj, 1))
#define SCM_AFTER_GUARD(obj) ((scm_t_guard) SCM_CELL_WORD (obj, 2))
#define SCM_GUARD_DATA(obj) ((void *) SCM_CELL_WORD (obj, 3))

static scm_t_bits tc16_guards;

static int
guards_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  scm_puts ("#<guards ", port);
  scm_intprint (SCM_UNPACK (SCM_CDR (exp)), 16, port);
  scm_putc ('>', port);
  return 1;
}

SCM
scm_internal_dynamic_wind (scm_t_guard before,
			   scm_t_inner inner,
			   scm_t_guard after,
			   void *inner_data,
			   void *guard_data)
{
  SCM guards, ans;
  before (guard_data);
  SCM_NEWSMOB3 (guards, tc16_guards, (scm_t_bits) before, 
		(scm_t_bits) after, (scm_t_bits) guard_data);
  scm_dynwinds = scm_acons (guards, SCM_BOOL_F, scm_dynwinds);
  ans = inner (inner_data);
  scm_dynwinds = SCM_CDR (scm_dynwinds);
  after (guard_data);
  return ans;
}

#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)
{
 tail:
  if (SCM_EQ_P (to, scm_dynwinds));
  else if (delta < 0)
    {
      SCM wind_elt;
      SCM wind_key;

      scm_dowinds (SCM_CDR (to), 1 + delta);
      wind_elt = SCM_CAR (to);
#if 0
      if (SCM_INUMP (wind_elt))
	{
	  scm_cross_dynwind_binding_scope (wind_elt, 0);
	}
      else
#endif
	{
	  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_swap_fluids (wind_key, SCM_CDR (wind_elt));
		}
	      else if (SCM_GUARDSP (wind_key))
		SCM_BEFORE_GUARD (wind_key) (SCM_GUARD_DATA (wind_key));
	      else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
		scm_call_0 (wind_key);
	    }
	}
      scm_dynwinds = to;
    }
  else
    {
      SCM from;
      SCM wind_elt;
      SCM wind_key;

      from = SCM_CDR (SCM_CAR (scm_dynwinds));
      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
	{
	  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_swap_fluids_reverse (wind_key, SCM_CDR (wind_elt));
		}
	      else if (SCM_GUARDSP (wind_key))
		SCM_AFTER_GUARD (wind_key) (SCM_GUARD_DATA (wind_key));
	      else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
		scm_call_0 (from);
	    }
	}
      delta--;
      goto tail;		/* scm_dowinds(to, delta-1); */
    }
}


void
scm_init_dynwind ()
{
  tc16_guards = scm_make_smob_type ("guards", 0);
  scm_set_smob_print (tc16_guards, guards_print);
#include "libguile/dynwind.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/
Commit	Line	Data
e81d98ec	1	/* Copyright (C) 1995,1996,1998,1999,2000,2001 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
a0599745 MD	21	#include "libguile/_scm.h"
	22	#include "libguile/eval.h"
	23	#include "libguile/alist.h"
	24	#include "libguile/fluids.h"
	25	#include "libguile/ports.h"
	26	#include "libguile/smob.h"
0f2d19dd	27
a0599745	28	#include "libguile/dynwind.h"
0f2d19dd JB	29	\f
	30
	31	/* {Dynamic wind}
b3460a50 MV	32
	33	Things that can be on the wind list:
	34
	35	(enter-proc . leave-proc) dynamic-wind
	36	(tag . jmpbuf) catch
	37	(tag . lazy-catch) lazy-catch
	38	tag is either a symbol or a boolean
	39
	40	((fluid ...) . (value ...)) with-fluids
	41
	42	*/
0f2d19dd JB	43
	44
	45
3b3b36dd	46	SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
1e6808ea MG	47	(SCM in_guard, SCM thunk, SCM out_guard),
	48	"All three arguments must be 0-argument procedures.\n"
	49	"@var{in_guard} is called, then @var{thunk}, then\n"
	50	"@var{out_guard}.\n"
	51	"\n"
	52	"If, any time during the execution of @var{thunk}, the\n"
	53	"continuation of the @code{dynamic_wind} expression is escaped\n"
	54	"non-locally, @var{out_guard} is called. If the continuation of\n"
	55	"the dynamic-wind is re-entered, @var{in_guard} is called. Thus\n"
	56	"@var{in_guard} and @var{out_guard} may be called any number of\n"
	57	"times.\n"
	58	"@lisp\n"
b380b885	59	"(define x 'normal-binding)\n"
1e6808ea	60	"@result{} x\n"
9401323e	61	"(define a-cont (call-with-current-continuation\n"
b380b885 MD	62	" (lambda (escape)\n"
	63	" (let ((old-x x))\n"
	64	" (dynamic-wind\n"
	65	" ;; in-guard:\n"
	66	" ;;\n"
1e6808ea MG	67	" (lambda () (set! x 'special-binding))\n"
1e6808ea MG	68	"\n"
b380b885 MD	69	" ;; thunk\n"
	70	" ;;\n"
	71	" (lambda () (display x) (newline)\n"
	72	" (call-with-current-continuation escape)\n"
	73	" (display x) (newline)\n"
1e6808ea MG	74	" x)\n"
1e6808ea MG	75	"\n"
b380b885 MD	76	" ;; out-guard:\n"
b380b885 MD	77	" ;;\n"
1e6808ea MG	78	" (lambda () (set! x old-x)))))))\n"
1e6808ea MG	79	"\n"
9401323e	80	";; Prints:\n"
b380b885 MD	81	"special-binding\n"
b380b885 MD	82	";; Evaluates to:\n"
1e6808ea	83	"@result{} a-cont\n"
b380b885	84	"x\n"
1e6808ea	85	"@result{} normal-binding\n"
b380b885 MD	86	"(a-cont #f)\n"
	87	";; Prints:\n"
	88	"special-binding\n"
	89	";; Evaluates to:\n"
1e6808ea	90	"@result{} a-cont ;; the value of the (define a-cont...)\n"
b380b885	91	"x\n"
1e6808ea	92	"@result{} normal-binding\n"
b380b885 MD	93	"a-cont\n"
b380b885 MD	94	"@result{} special-binding\n"
1e6808ea	95	"@end lisp")
1bbd0b84	96	#define FUNC_NAME s_scm_dynamic_wind
0f2d19dd JB	97	{
0f2d19dd JB	98	SCM ans;
1e6808ea MG	99	SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (out_guard)),
1e6808ea MG	100	out_guard,
1bbd0b84	101	SCM_ARG3, FUNC_NAME);
fdc28395	102	scm_call_0 (in_guard);
1e6808ea	103	scm_dynwinds = scm_acons (in_guard, out_guard, scm_dynwinds);
fdc28395	104	ans = scm_call_0 (thunk);
0f2d19dd	105	scm_dynwinds = SCM_CDR (scm_dynwinds);
fdc28395	106	scm_call_0 (out_guard);
0f2d19dd JB	107	return ans;
0f2d19dd JB	108	}
1bbd0b84	109	#undef FUNC_NAME
0f2d19dd	110
3346a90f MD	111	/* The implementation of a C-callable dynamic-wind,
	112	* scm_internal_dynamic_wind, requires packaging of C pointers in a
	113	* smob. Objects of this type are pushed onto the dynwind chain.
	114	*/
	115
e841c3e0	116	#define SCM_GUARDSP(obj) SCM_TYP16_PREDICATE (tc16_guards, obj)
92c2555f MV	117	#define SCM_BEFORE_GUARD(obj) ((scm_t_guard) SCM_CELL_WORD (obj, 1))
92c2555f MV	118	#define SCM_AFTER_GUARD(obj) ((scm_t_guard) SCM_CELL_WORD (obj, 2))
bd47429e	119	#define SCM_GUARD_DATA(obj) ((void *) SCM_CELL_WORD (obj, 3))
3346a90f	120
92c2555f	121	static scm_t_bits tc16_guards;
3346a90f	122
3346a90f	123	static int
e81d98ec	124	guards_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
3346a90f MD	125	{
3346a90f MD	126	scm_puts ("#<guards ", port);
f1267706	127	scm_intprint (SCM_UNPACK (SCM_CDR (exp)), 16, port);
3346a90f MD	128	scm_putc ('>', port);
	129	return 1;
	130	}
	131
3346a90f	132	SCM
92c2555f MV	133	scm_internal_dynamic_wind (scm_t_guard before,
	134	scm_t_inner inner,
	135	scm_t_guard after,
3346a90f MD	136	void *inner_data,
	137	void *guard_data)
	138	{
	139	SCM guards, ans;
3346a90f	140	before (guard_data);
92c2555f MV	141	SCM_NEWSMOB3 (guards, tc16_guards, (scm_t_bits) before,
92c2555f MV	142	(scm_t_bits) after, (scm_t_bits) guard_data);
3346a90f MD	143	scm_dynwinds = scm_acons (guards, SCM_BOOL_F, scm_dynwinds);
	144	ans = inner (inner_data);
	145	scm_dynwinds = SCM_CDR (scm_dynwinds);
	146	after (guard_data);
	147	return ans;
	148	}
1cc91f1b	149
c2654ef0	150	#ifdef GUILE_DEBUG
a1ec6916	151	SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
1bbd0b84	152	(),
156149ad MG	153	"Return the current wind chain. The wind chain contains all\n"
	154	"information required by @code{dynamic-wind} to call its\n"
	155	"argument thunks when entering/exiting its scope.")
1bbd0b84	156	#define FUNC_NAME s_scm_wind_chain
c2654ef0 MD	157	{
	158	return scm_dynwinds;
	159	}
1bbd0b84	160	#undef FUNC_NAME
c2654ef0 MD	161	#endif
c2654ef0 MD	162
2e171178	163	void
904a077d	164	scm_swap_bindings (SCM vars, SCM vals)
6778caf9 MD	165	{
	166	SCM tmp;
	167	while (SCM_NIMP (vals))
	168	{
904a077d MV	169	tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
904a077d MV	170	SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
6778caf9	171	SCM_SETCAR (vals, tmp);
904a077d	172	vars = SCM_CDR (vars);
6778caf9 MD	173	vals = SCM_CDR (vals);
	174	}
	175	}
c2654ef0	176
0f2d19dd	177	void
c014a02e	178	scm_dowinds (SCM to, long delta)
0f2d19dd JB	179	{
0f2d19dd JB	180	tail:
843524cc	181	if (SCM_EQ_P (to, scm_dynwinds));
1be6b49c	182	else if (delta < 0)
0f2d19dd JB	183	{
	184	SCM wind_elt;
	185	SCM wind_key;
	186
	187	scm_dowinds (SCM_CDR (to), 1 + delta);
	188	wind_elt = SCM_CAR (to);
	189	#if 0
	190	if (SCM_INUMP (wind_elt))
	191	{
	192	scm_cross_dynwind_binding_scope (wind_elt, 0);
	193	}
	194	else
	195	#endif
	196	{
	197	wind_key = SCM_CAR (wind_elt);
904a077d	198	/* key = #t \| symbol \| thunk \| list of variables \| list of fluids */
6778caf9	199	if (SCM_NIMP (wind_key))
b3460a50	200	{
904a077d MV	201	if (SCM_CONSP (wind_key))
	202	{
	203	if (SCM_VARIABLEP (SCM_CAR (wind_key)))
	204	scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
	205	else if (SCM_FLUIDP (SCM_CAR (wind_key)))
	206	scm_swap_fluids (wind_key, SCM_CDR (wind_elt));
	207	}
4725c298 MD	208	else if (SCM_GUARDSP (wind_key))
	209	SCM_BEFORE_GUARD (wind_key) (SCM_GUARD_DATA (wind_key));
	210	else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
fdc28395	211	scm_call_0 (wind_key);
b3460a50	212	}
0f2d19dd JB	213	}
	214	scm_dynwinds = to;
	215	}
	216	else
	217	{
	218	SCM from;
	219	SCM wind_elt;
	220	SCM wind_key;
	221
	222	from = SCM_CDR (SCM_CAR (scm_dynwinds));
	223	wind_elt = SCM_CAR (scm_dynwinds);
	224	scm_dynwinds = SCM_CDR (scm_dynwinds);
	225	#if 0
	226	if (SCM_INUMP (wind_elt))
	227	{
	228	scm_cross_dynwind_binding_scope (wind_elt, 0);
	229	}
	230	else
	231	#endif
	232	{
	233	wind_key = SCM_CAR (wind_elt);
6778caf9	234	if (SCM_NIMP (wind_key))
b3460a50	235	{
904a077d MV	236	if (SCM_CONSP (wind_key))
	237	{
	238	if (SCM_VARIABLEP (SCM_CAR (wind_key)))
	239	scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
	240	else if (SCM_FLUIDP (SCM_CAR (wind_key)))
	241	scm_swap_fluids_reverse (wind_key, SCM_CDR (wind_elt));
	242	}
4725c298 MD	243	else if (SCM_GUARDSP (wind_key))
	244	SCM_AFTER_GUARD (wind_key) (SCM_GUARD_DATA (wind_key));
	245	else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
fdc28395	246	scm_call_0 (from);
b3460a50	247	}
0f2d19dd JB	248	}
	249	delta--;
	250	goto tail; /* scm_dowinds(to, delta-1); */
	251	}
	252	}
	253
	254
1cc91f1b	255
0f2d19dd JB	256	void
0f2d19dd JB	257	scm_init_dynwind ()
0f2d19dd	258	{
e841c3e0 KN	259	tc16_guards = scm_make_smob_type ("guards", 0);
e841c3e0 KN	260	scm_set_smob_print (tc16_guards, guards_print);
a0599745	261	#include "libguile/dynwind.x"
0f2d19dd	262	}
89e00824 ML	263
	264	/*
	265	Local Variables:
	266	c-file-style: "gnu"
	267	End:
	268	*/