-/* Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
\f
-#include <stdio.h>
-#include "_scm.h"
-#include "eval.h"
-#include "alist.h"
-#include "fluids.h"
-#include "ports.h"
-#include "smob.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 "dynwind.h"
+#include "libguile/dynwind.h"
\f
/* {Dynamic wind}
SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
- (SCM thunk1, SCM thunk2, SCM thunk3),
- "All three arguments must be 0-argument procedures.\n\n"
- "@var{in-guard} is called, then @var{thunk}, then @var{out-guard}.\n\n"
- "If, any time during the execution of @var{thunk}, the continuation\n"
- "of the @code{dynamic-wind} expression is escaped non-locally, @var{out-guard}\n"
- "is called. If the continuation of the dynamic-wind is re-entered,\n"
- "@var{in-guard} is called. Thus @var{in-guard} and @var{out-guard} may\n"
- "be called any number of times.\n\n"
- "@example\n"
+ (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\n"
- "(define a-cont (call-with-current-continuation \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"
+ " (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"
+ " x)\n"
+ "\n"
" ;; out-guard:\n"
" ;;\n"
- " (lambda () (set! x old-x)))))))\n\n"
- ";; Prints: \n"
+ " (lambda () (set! x old-x)))))))\n"
+ "\n"
+ ";; Prints:\n"
"special-binding\n"
";; Evaluates to:\n"
- "@result{} a-cont\n\n"
+ "@result{} a-cont\n"
"x\n"
- "@result{} normal-binding\n\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\n"
+ "@result{} a-cont ;; the value of the (define a-cont...)\n"
"x\n"
- "@result{} normal-binding\n\n"
+ "@result{} normal-binding\n"
"a-cont\n"
"@result{} special-binding\n"
- "@end example\n"
- "")
+ "@end lisp")
#define FUNC_NAME s_scm_dynamic_wind
{
SCM ans;
- SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk3)),
- thunk3,
+ SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (out_guard)),
+ out_guard,
SCM_ARG3, FUNC_NAME);
- scm_apply (thunk1, SCM_EOL, SCM_EOL);
- scm_dynwinds = scm_acons (thunk1, thunk3, scm_dynwinds);
- ans = scm_apply (thunk2, SCM_EOL, SCM_EOL);
+ 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_apply (thunk3, SCM_EOL, SCM_EOL);
+ scm_call_0 (out_guard);
return ans;
}
#undef FUNC_NAME
* smob. Objects of this type are pushed onto the dynwind chain.
*/
-#define SCM_GUARDSP(obj) SCM_SMOB_PREDICATE (tc16_guards, obj)
-#define SCM_BEFORE_GUARD(obj) ((scm_guard_t) SCM_CELL_WORD (obj, 1))
-#define SCM_AFTER_GUARD(obj) ((scm_guard_t) SCM_CELL_WORD (obj, 2))
+#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 long tc16_guards;
+static scm_t_bits tc16_guards;
static int
-printguards (SCM exp, SCM port, scm_print_state *pstate)
+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
-scm_internal_dynamic_wind (scm_guard_t before,
- scm_inner_t inner,
- scm_guard_t after,
+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, before, after, 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);
#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
-static void
-scm_swap_bindings (SCM glocs, SCM vals)
+void
+scm_swap_bindings (SCM vars, SCM vals)
{
SCM tmp;
while (SCM_NIMP (vals))
{
- tmp = SCM_GLOC_VAL (SCM_CAR (glocs));
- SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (glocs)) - 1L),
- SCM_CAR (vals));
+ tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
+ SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
SCM_SETCAR (vals, tmp);
- glocs = SCM_CDR (glocs);
+ vars = SCM_CDR (vars);
vals = SCM_CDR (vals);
}
}
scm_dowinds (SCM to, long delta)
{
tail:
- if (scm_dynwinds == to);
- else if (0 > delta)
+ if (SCM_EQ_P (to, scm_dynwinds));
+ else if (delta < 0)
{
SCM wind_elt;
SCM wind_key;
#endif
{
wind_key = SCM_CAR (wind_elt);
- /* key = #t | symbol | thunk | list of glocs | list of fluids */
+ /* key = #t | symbol | thunk | list of variables | list of fluids */
if (SCM_NIMP (wind_key))
{
- if (SCM_TYP3 (wind_key) == scm_tc3_cons_gloc)
- scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
- else if (SCM_TYP3 (wind_key) == scm_tc3_cons)
- scm_swap_fluids (wind_key, SCM_CDR (wind_elt));
+ 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_apply (wind_key, SCM_EOL, SCM_EOL);
+ scm_call_0 (wind_key);
}
}
scm_dynwinds = to;
wind_key = SCM_CAR (wind_elt);
if (SCM_NIMP (wind_key))
{
- if (SCM_TYP3 (wind_key) == scm_tc3_cons_gloc)
- scm_swap_bindings (wind_key, from);
- else if (SCM_TYP3 (wind_key) == scm_tc3_cons)
- scm_swap_fluids_reverse (wind_key, from);
+ 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_apply (from, SCM_EOL, SCM_EOL);
+ scm_call_0 (from);
}
}
delta--;
void
scm_init_dynwind ()
{
- tc16_guards = scm_make_smob_type_mfpe ("guards", 0,
- NULL, scm_free0, printguards, NULL);
-#include "dynwind.x"
+ tc16_guards = scm_make_smob_type ("guards", 0);
+ scm_set_smob_print (tc16_guards, guards_print);
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/dynwind.x"
+#endif
}
/*
HCoop / bpt / guile.git / blobdiff