X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/1e6808ea204cef454e41af1e2f309100ab99e9e1..eb7e1603ad497d0efff686e26e23af987c567721:/libguile/dynwind.c diff --git a/libguile/dynwind.c b/libguile/dynwind.c index c79097b61..28dbb0d45 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -1,49 +1,25 @@ -/* Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004 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 - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. + * 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 exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * 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. * - * 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. */ + * 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 + */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ +#include + #include "libguile/_scm.h" #include "libguile/eval.h" #include "libguile/alist.h" @@ -58,13 +34,13 @@ 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 - */ @@ -84,7 +60,7 @@ SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0, "@lisp\n" "(define x 'normal-binding)\n" "@result{} x\n" - "(define a-cont (call-with-current-continuation \n" + "(define a-cont (call-with-current-continuation\n" " (lambda (escape)\n" " (let ((old-x x))\n" " (dynamic-wind\n" @@ -103,7 +79,7 @@ SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0, " ;;\n" " (lambda () (set! x old-x)))))))\n" "\n" - ";; Prints: \n" + ";; Prints:\n" "special-binding\n" ";; Evaluates to:\n" "@result{} a-cont\n" @@ -125,52 +101,136 @@ SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0, SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (out_guard)), out_guard, SCM_ARG3, FUNC_NAME); - scm_apply (in_guard, SCM_EOL, SCM_EOL); + scm_call_0 (in_guard); scm_dynwinds = scm_acons (in_guard, out_guard, scm_dynwinds); - ans = scm_apply (thunk, SCM_EOL, SCM_EOL); + ans = scm_call_0 (thunk); scm_dynwinds = SCM_CDR (scm_dynwinds); - scm_apply (out_guard, SCM_EOL, SCM_EOL); + 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. - */ +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; +} -#define SCM_GUARDSP(obj) SCM_TYP16_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)) +/* Frames and winders. */ -static scm_bits_t tc16_guards; +static scm_t_bits tc16_frame; +#define FRAME_P(f) SCM_SMOB_PREDICATE (tc16_frame, (f)) -static int -guards_print (SCM exp, SCM port, scm_print_state *pstate) +#define FRAME_F_REWINDABLE (1 << 16) +#define FRAME_REWINDABLE_P(f) (SCM_CELL_WORD_0(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_CELL_WORD_1 (w)) +#define WINDER_DATA(w) ((void *)SCM_CELL_WORD_2 (w)) + +#define WINDER_F_EXPLICIT (1 << 16) +#define WINDER_F_REWIND (1 << 17) +#define WINDER_F_MARK (1 << 18) +#define WINDER_EXPLICIT_P(w) (SCM_CELL_WORD_0(w) & WINDER_F_EXPLICIT) +#define WINDER_REWIND_P(w) (SCM_CELL_WORD_0(w) & WINDER_F_REWIND) +#define WINDER_MARK_P(w) (SCM_CELL_WORD_0(w) & WINDER_F_MARK) + +void +scm_frame_begin (scm_t_frame_flags flags) { - scm_puts ("#', port); - return 1; + SCM f; + scm_t_bits fl = ((flags&SCM_F_FRAME_REWINDABLE)? FRAME_F_REWINDABLE : 0); + SCM_NEWSMOB (f, tc16_frame | fl, 0); + scm_dynwinds = scm_cons (f, scm_dynwinds); } -SCM -scm_internal_dynamic_wind (scm_guard_t before, - scm_inner_t inner, - scm_guard_t after, - void *inner_data, - void *guard_data) +void +scm_frame_end (void) { - SCM guards, ans; - before (guard_data); - SCM_NEWSMOB3 (guards, tc16_guards, (scm_bits_t) before, - (scm_bits_t) after, (scm_bits_t) 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; + /* Unwind upto and including the next frame entry. We can only + encounter # 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 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_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0); + SCM_NEWSMOB2 (w, tc16_winder | fl, + (scm_t_bits) proc, (scm_t_bits) data); + 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 | WINDER_F_REWIND, + (scm_t_bits) proc, (scm_t_bits) data); + 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 | fl | WINDER_F_MARK, + (scm_t_bits) proc, SCM_UNPACK (data)); + 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 | WINDER_F_REWIND | WINDER_F_MARK, + (scm_t_bits) proc, SCM_UNPACK (data)); + scm_dynwinds = scm_cons (w, scm_dynwinds); + if (flags & SCM_F_WIND_EXPLICITLY) + proc (data); } #ifdef GUILE_DEBUG @@ -186,33 +246,43 @@ SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0, #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); } } -void +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_EQ_P (to, scm_dynwinds)); - else if (0 > delta) + if (SCM_EQ_P (to, scm_dynwinds)) + { + if (turn_func) + turn_func (data); + } + else if (delta < 0) { SCM wind_elt; SCM wind_key; - scm_dowinds (SCM_CDR (to), 1 + delta); + scm_i_dowinds (SCM_CDR (to), 1 + delta, turn_func, data); wind_elt = SCM_CAR (to); + #if 0 if (SCM_INUMP (wind_elt)) { @@ -221,31 +291,44 @@ scm_dowinds (SCM to, long delta) else #endif { - wind_key = SCM_CAR (wind_elt); - /* key = #t | symbol | thunk | list of glocs | list of fluids */ - if (SCM_NIMP (wind_key)) + 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 { - 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_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); + 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 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)) { @@ -254,17 +337,28 @@ scm_dowinds (SCM to, long delta) else #endif { - wind_key = SCM_CAR (wind_elt); - if (SCM_NIMP (wind_key)) + 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 { - 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_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); + 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--; @@ -272,16 +366,15 @@ scm_dowinds (SCM to, long delta) } } - - void scm_init_dynwind () { - tc16_guards = scm_make_smob_type ("guards", 0); - scm_set_smob_print (tc16_guards, guards_print); -#ifndef SCM_MAGIC_SNARFER + 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" -#endif } /*