-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1998, 1999, 2000 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
* If you write modifications of your own for GUILE, it is your choice
* 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 "eval.h"
#include "alist.h"
#include "fluids.h"
-#include "genio.h"
+#include "ports.h"
#include "smob.h"
#include "dynwind.h"
-SCM_PROC(s_dynamic_wind, "dynamic-wind", 3, 0, 0, scm_dynamic_wind);
-
-SCM
-scm_dynamic_wind (thunk1, thunk2, thunk3)
- SCM thunk1;
- SCM thunk2;
- SCM thunk3;
+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"
+ "(define x 'normal-binding)\n"
+ "@result{} x\n\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\n"
+ "x\n"
+ "@result{} normal-binding\n\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"
+ "x\n"
+ "@result{} normal-binding\n\n"
+ "a-cont\n"
+ "@result{} special-binding\n"
+ "@end example\n"
+ "")
+#define FUNC_NAME s_scm_dynamic_wind
{
SCM ans;
+ SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk3)),
+ thunk3,
+ 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_apply (thunk3, SCM_EOL, SCM_EOL);
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.
*/
-typedef struct guardsmem {
- scm_guard_t before;
- scm_guard_t after;
- void *data;
-} guardsmem;
-
-#define SCM_GUARDSMEM(obj) ((guardsmem *) SCM_CDR (obj))
-#define SCM_BEFORE_GUARD(obj) (SCM_GUARDSMEM (obj)->before)
-#define SCM_AFTER_GUARD(obj) (SCM_GUARDSMEM (obj)->after)
-#define SCM_GUARD_DATA(obj) (SCM_GUARDSMEM (obj)->data)
-#define SCM_GUARDSP(obj) (SCM_CAR (obj) == tc16_guards)
+#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_GUARD_DATA(obj) ((void *) SCM_CELL_WORD (obj, 3))
static long tc16_guards;
-static scm_sizet
-freeguards (SCM guards)
-{
- scm_must_free ((char *) SCM_CDR (guards));
- return sizeof (guardsmem);
-}
-
static int
printguards (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts ("#<guards ", port);
- scm_intprint (SCM_CDR (exp), 16, port);
+ scm_intprint (SCM_UNPACK (SCM_CDR (exp)), 16, port);
scm_putc ('>', port);
return 1;
}
-static scm_smobfuns guardsmob = {
- 0,
- freeguards,
- printguards,
- 0
-};
-
SCM
scm_internal_dynamic_wind (scm_guard_t before,
scm_inner_t inner,
void *guard_data)
{
SCM guards, ans;
- guardsmem *g;
before (guard_data);
- SCM_NEWCELL (guards);
- SCM_DEFER_INTS;
- g = (guardsmem *) scm_must_malloc (sizeof (*g), "guards");
- g->before = before;
- g->after = after;
- g->data = guard_data;
- SCM_SETCDR (guards, g);
- SCM_SETCAR (guards, tc16_guards);
- SCM_ALLOW_INTS;
+ SCM_NEWSMOB3 (guards, tc16_guards, before, after, 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_PROC (s_wind_chain, "wind-chain", 0, 0, 0, scm_wind_chain);
-
-SCM
-scm_wind_chain ()
+SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
+ (),
+ "")
+#define FUNC_NAME s_scm_wind_chain
{
return scm_dynwinds;
}
+#undef FUNC_NAME
#endif
+static void
+scm_swap_bindings (SCM glocs, SCM vals)
+{
+ SCM tmp;
+ while (SCM_NIMP (vals))
+ {
+ tmp = SCM_GLOC_VAL (SCM_CAR (glocs));
+ SCM_SETCDR (SCM_CAR (glocs) - 1L, SCM_CAR (vals));
+ SCM_SETCAR (vals, tmp);
+ glocs = SCM_CDR (glocs);
+ vals = SCM_CDR (vals);
+ }
+}
void
-scm_dowinds (to, delta)
- SCM to;
- long delta;
+scm_dowinds (SCM to, long delta)
{
tail:
if (scm_dynwinds == to);
#endif
{
wind_key = SCM_CAR (wind_elt);
- if (!(SCM_NIMP (wind_key) && SCM_SYMBOLP (wind_key))
- && (wind_key != SCM_BOOL_F)
- && (wind_key != SCM_BOOL_T))
+ /* key = #t | symbol | thunk | list of glocs | list of fluids */
+ if (SCM_NIMP (wind_key))
{
- if (SCM_NIMP (wind_key) && SCM_CONSP (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));
- else if (SCM_NIMP (wind_key) && SCM_GUARDSP (wind_key))
+ else if (SCM_GUARDSP (wind_key))
SCM_BEFORE_GUARD (wind_key) (SCM_GUARD_DATA (wind_key));
- else
+ else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
scm_apply (wind_key, SCM_EOL, SCM_EOL);
}
}
#endif
{
wind_key = SCM_CAR (wind_elt);
- if (!(SCM_NIMP (wind_key) && SCM_SYMBOLP (wind_key))
- && (wind_key != SCM_BOOL_F)
- && (wind_key != SCM_BOOL_T))
+ if (SCM_NIMP (wind_key))
{
- if (SCM_NIMP (wind_key) && SCM_CONSP (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);
- else if (SCM_NIMP (wind_key) && SCM_GUARDSP (wind_key))
+ else if (SCM_GUARDSP (wind_key))
SCM_AFTER_GUARD (wind_key) (SCM_GUARD_DATA (wind_key));
- else
+ else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
scm_apply (from, SCM_EOL, SCM_EOL);
}
}
void
scm_init_dynwind ()
{
- tc16_guards = scm_newsmob (&guardsmob);
+ tc16_guards = scm_make_smob_type_mfpe ("guards", 0,
+ NULL, scm_free0, printguards, NULL);
#include "dynwind.x"
}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff