libguile/root.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001, 2002 Free Software Foundation, Inc.
   2  *
   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.
   7  *
   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.
  12  *
  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  */
  17
  18
  19 \f
  20
  21 #include <string.h>
  22 #include "libguile/_scm.h"
  23 #include "libguile/stackchk.h"
  24 #include "libguile/dynwind.h"
  25 #include "libguile/eval.h"
  26 #include "libguile/smob.h"
  27 #include "libguile/pairs.h"
  28 #include "libguile/throw.h"
  29 #include "libguile/fluids.h"
  30 #include "libguile/ports.h"
  31
  32 #include "libguile/root.h"
  33 \f
  34
  35 SCM scm_sys_protects[SCM_NUM_PROTECTS];
  36
  37 scm_t_bits scm_tc16_root;
  38
  39 \f
  40
  41 static SCM
  42 root_mark (SCM root)
  43 {
  44   scm_root_state *s = SCM_ROOT_STATE (root);
  45
  46   scm_gc_mark (s->rootcont);
  47   scm_gc_mark (s->dynwinds);
  48   scm_gc_mark (s->progargs);
  49   scm_gc_mark (s->exitval);
  50   scm_gc_mark (s->cur_inp);
  51   scm_gc_mark (s->cur_outp);
  52   scm_gc_mark (s->cur_errp);
  53   /* No need to gc mark def_loadp */
  54   scm_gc_mark (s->fluids);
  55   scm_gc_mark (s->active_asyncs);
  56   scm_gc_mark (s->signal_asyncs);
  57   return SCM_ROOT_STATE (root) -> parent;
  58 }
  59
  60
  61 static int
  62 root_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
  63 {
  64   scm_puts ("#<root ", port);
  65   scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
  66   scm_putc('>', port);
  67   return 1;
  68 }
  69
  70
  71 \f
  72
  73 SCM
  74 scm_make_root (SCM parent)
  75 {
  76   SCM root;
  77   scm_root_state *root_state;
  78
  79   root_state = (scm_root_state *) scm_gc_malloc (sizeof (scm_root_state),
  80                                                  "root state");
  81   if (SCM_ROOTP (parent))
  82     {
  83       memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state));
  84       root_state->parent = parent;
  85     }
  86   else
  87     {
  88       root_state->parent = SCM_BOOL_F;
  89
  90       /* Initialize everything right now, in case a GC happens early.  */
  91       root_state->rootcont
  92         = root_state->dynwinds
  93         = root_state->progargs
  94         = root_state->exitval
  95         = root_state->cur_inp
  96         = root_state->cur_outp
  97         = root_state->cur_errp
  98         = root_state->cur_loadp
  99         = root_state->fluids
 100         = root_state->handle
 101         = root_state->parent
 102         = SCM_BOOL_F;
 103     }
 104
 105   root_state->active_asyncs = SCM_EOL;
 106   root_state->signal_asyncs = SCM_EOL;
 107   root_state->block_asyncs = 0;
 108   root_state->pending_asyncs = 1;
 109
 110   SCM_NEWSMOB (root, scm_tc16_root, root_state);
 111   root_state->handle = root;
 112
 113   if (SCM_ROOTP (parent))
 114     /* Must be done here so that fluids are GC protected */
 115     scm_copy_fluids (root_state);
 116
 117   return root;
 118 }
 119
 120 /* {call-with-dynamic-root}
 121  *
 122  * Suspending the current thread to evaluate a thunk on the
 123  * same C stack but under a new root.
 124  *
 125  * Calls to call-with-dynamic-root return exactly once (unless
 126  * the process is somehow exitted).  */
 127
 128 /* Some questions about cwdr:
 129
 130    Couldn't the body just be a closure?  Do we really need to pass
 131    args through to it?
 132
 133    The semantics are a lot like catch's; in fact, we call
 134    scm_internal_catch to take care of that part of things.  Wouldn't
 135    it be cleaner to say that uncaught throws just disappear into the
 136    ether (or print a message to stderr), and let the caller use catch
 137    themselves if they want to?
 138
 139    -JimB */
 140
 141 #if 0
 142 SCM scm_exitval;                /* INUM with return value */
 143 #endif
 144 static long n_dynamic_roots = 0;
 145
 146
 147 /* cwdr fills out both of these structures, and then passes a pointer
 148    to them through scm_internal_catch to the cwdr_body and
 149    cwdr_handler functions, to tell them how to behave and to get
 150    information back from them.
 151
 152    A cwdr is a lot like a catch, except there is no tag (all
 153    exceptions are caught), and the body procedure takes the arguments
 154    passed to cwdr as A1 and ARGS.  The handler is also special since
 155    it is not directly run from scm_internal_catch.  It is executed
 156    outside the new dynamic root. */
 157
 158 struct cwdr_body_data {
 159   /* Arguments to pass to the cwdr body function.  */
 160   SCM a1, args;
 161
 162   /* Scheme procedure to use as body of cwdr.  */
 163   SCM body_proc;
 164 };
 165
 166 struct cwdr_handler_data {
 167   /* Do we need to run the handler? */
 168   int run_handler;
 169
 170   /* The tag and args to pass it. */
 171   SCM tag, args;
 172 };
 173
 174
 175 /* Invoke the body of a cwdr, assuming that the throw handler has
 176    already been set up.  DATA points to a struct set up by cwdr that
 177    says what proc to call, and what args to apply it to.
 178
 179    With a little thought, we could replace this with scm_body_thunk,
 180    but I don't want to mess with that at the moment.  */
 181 static SCM
 182 cwdr_body (void *data)
 183 {
 184   struct cwdr_body_data *c = (struct cwdr_body_data *) data;
 185
 186   return scm_apply (c->body_proc, c->a1, c->args);
 187 }
 188
 189 /* Record the fact that the body of the cwdr has thrown.  Record
 190    enough information to invoke the handler later when the dynamic
 191    root has been deestablished.  */
 192
 193 static SCM
 194 cwdr_handler (void *data, SCM tag, SCM args)
 195 {
 196   struct cwdr_handler_data *c = (struct cwdr_handler_data *) data;
 197
 198   c->run_handler = 1;
 199   c->tag = tag;
 200   c->args = args;
 201   return SCM_UNSPECIFIED;
 202 }
 203
 204 /* This is the basic code for new root creation.
 205  *
 206  * WARNING!  The order of actions in this routine is in many ways
 207  * critical.  E. g., it is essential that an error doesn't leave Guile
 208  * in a messed up state.  */
 209
 210 SCM
 211 scm_internal_cwdr (scm_t_catch_body body, void *body_data,
 212                    scm_t_catch_handler handler, void *handler_data,
 213                    SCM_STACKITEM *stack_start)
 214 {
 215   SCM old_rootcont, old_winds;
 216   struct cwdr_handler_data my_handler_data;
 217   SCM answer;
 218
 219   /* Create a fresh root continuation.  */
 220   {
 221     SCM new_rootcont;
 222
 223     SCM_REDEFER_INTS;
 224     {
 225       scm_t_contregs *contregs = scm_gc_malloc (sizeof (scm_t_contregs),
 226                                                 "continuation");
 227
 228       contregs->num_stack_items = 0;
 229       contregs->dynenv = SCM_EOL;
 230       contregs->base = stack_start;
 231       contregs->seq = ++n_dynamic_roots;
 232       contregs->throw_value = SCM_BOOL_F;
 233 #ifdef DEBUG_EXTENSIONS
 234       contregs->dframe = 0;
 235 #endif
 236       SCM_NEWSMOB (new_rootcont, scm_tc16_continuation, contregs);
 237     }
 238     old_rootcont = scm_rootcont;
 239     scm_rootcont = new_rootcont;
 240     SCM_REALLOW_INTS;
 241   }
 242
 243   /* Exit caller's dynamic state.
 244    */
 245   old_winds = scm_dynwinds;
 246   scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
 247 #ifdef DEBUG_EXTENSIONS
 248   SCM_DFRAME (old_rootcont) = scm_last_debug_frame;
 249   scm_last_debug_frame = 0;
 250 #endif
 251
 252   {
 253     my_handler_data.run_handler = 0;
 254     answer = scm_internal_catch (SCM_BOOL_T,
 255                                  body, body_data,
 256                                  cwdr_handler, &my_handler_data);
 257   }
 258
 259   scm_dowinds (old_winds, - scm_ilength (old_winds));
 260   SCM_REDEFER_INTS;
 261 #ifdef DEBUG_EXTENSIONS
 262   scm_last_debug_frame = SCM_DFRAME (old_rootcont);
 263 #endif
 264   scm_rootcont = old_rootcont;
 265   SCM_REALLOW_INTS;
 266
 267   /* Now run the real handler iff the body did a throw. */
 268   if (my_handler_data.run_handler)
 269     return handler (handler_data, my_handler_data.tag, my_handler_data.args);
 270   else
 271     return answer;
 272 }
 273
 274 /* The original CWDR for invoking Scheme code with a Scheme handler. */
 275
 276 static SCM
 277 cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)
 278 {
 279   struct cwdr_body_data c;
 280
 281   c.a1 = a1;
 282   c.args = args;
 283   c.body_proc = proc;
 284
 285   return scm_internal_cwdr (cwdr_body, &c,
 286                             scm_handle_by_proc, &handler,
 287                             stack_start);
 288 }
 289
 290 SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0,
 291            (SCM thunk, SCM handler),
 292             "Evaluate @code{(thunk)} in a new dynamic context, returning its value.\n\n"
 293             "If an error occurs during evaluation, apply @var{handler} to the\n"
 294             "arguments to the throw, just as @code{throw} would.  If this happens,\n"
 295             "@var{handler} is called outside the scope of the new root -- it is\n"
 296             "called in the same dynamic context in which\n"
 297             "@code{call-with-dynamic-root} was evaluated.\n\n"
 298             "If @var{thunk} captures a continuation, the continuation is rooted at\n"
 299             "the call to @var{thunk}.  In particular, the call to\n"
 300             "@code{call-with-dynamic-root} is not captured.  Therefore,\n"
 301             "@code{call-with-dynamic-root} always returns at most one time.\n\n"
 302             "Before calling @var{thunk}, the dynamic-wind chain is un-wound back to\n"
 303             "the root and a new chain started for @var{thunk}.  Therefore, this call\n"
 304             "may not do what you expect:\n\n"
 305             "@lisp\n"
 306             ";; Almost certainly a bug:\n"
 307             "(with-output-to-port\n"
 308             " some-port\n\n"
 309             " (lambda ()\n"
 310             "   (call-with-dynamic-root\n"
 311             "    (lambda ()\n"
 312             "      (display 'fnord)\n"
 313             "      (newline))\n"
 314             "    (lambda (errcode) errcode))))\n"
 315             "@end lisp\n\n"
 316             "The problem is, on what port will @samp{fnord} be displayed?  You\n"
 317             "might expect that because of the @code{with-output-to-port} that\n"
 318             "it will be displayed on the port bound to @code{some-port}.  But it\n"
 319             "probably won't -- before evaluating the thunk, dynamic winds are\n"
 320             "unwound, including those created by @code{with-output-to-port}.\n"
 321             "So, the standard output port will have been re-set to its default value\n"
 322             "before @code{display} is evaluated.\n\n"
 323             "(This function was added to Guile mostly to help calls to functions in C\n"
 324             "libraries that can not tolerate non-local exits or calls that return\n"
 325             "multiple times.  If such functions call back to the interpreter, it should\n"
 326             "be under a new dynamic root.)")
 327 #define FUNC_NAME s_scm_call_with_dynamic_root
 328 {
 329   SCM_STACKITEM stack_place;
 330   return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
 331 }
 332 #undef FUNC_NAME
 333
 334 SCM_DEFINE (scm_dynamic_root, "dynamic-root", 0, 0, 0,
 335            (),
 336             "Return an object representing the current dynamic root.\n\n"
 337             "These objects are only useful for comparison using @code{eq?}.\n"
 338             "They are currently represented as numbers, but your code should\n"
 339             "in no way depend on this.")
 340 #define FUNC_NAME s_scm_dynamic_root
 341 {
 342   return scm_ulong2num (SCM_SEQ (scm_root->rootcont));
 343 }
 344 #undef FUNC_NAME
 345
 346 SCM
 347 scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler)
 348 {
 349   SCM_STACKITEM stack_place;
 350   return cwdr (proc, a1, args, handler, &stack_place);
 351 }
 352
 353 \f
 354
 355 void
 356 scm_init_root ()
 357 {
 358   scm_tc16_root = scm_make_smob_type ("root", sizeof (struct scm_root_state));
 359   scm_set_smob_mark (scm_tc16_root, root_mark);
 360   scm_set_smob_print (scm_tc16_root, root_print);
 361
 362 #include "libguile/root.x"
 363 }
 364
 365 /*
 366   Local Variables:
 367   c-file-style: "gnu"
 368   End:
 369 */