libguile/root.c

   1 /*      Copyright (C) 1995,1996,1997,1998, 1999 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45 #include "stackchk.h"
  46 #include "dynwind.h"
  47 #include "eval.h"
  48 #include "genio.h"
  49 #include "smob.h"
  50 #include "pairs.h"
  51 #include "throw.h"
  52 #include "fluids.h"
  53
  54 #include "root.h"
  55 \f
  56
  57 /* Define this if you want to try out the stack allocation of cwdr's
  58    jumpbuf.  It works for me but I'm still worried that the dynwinds
  59    might be able to make a mess. */
  60
  61 #undef USE_STACKJMPBUF
  62
  63 SCM scm_sys_protects[SCM_NUM_PROTECTS];
  64
  65 long scm_tc16_root;
  66
  67 #ifndef USE_THREADS
  68 struct scm_root_state *scm_root;
  69 #endif
  70
  71 \f
  72
  73 static SCM mark_root SCM_P ((SCM));
  74
  75 static SCM
  76 mark_root (root)
  77      SCM root;
  78 {
  79   scm_root_state *s = SCM_ROOT_STATE (root);
  80
  81   scm_gc_mark (s->rootcont);
  82   scm_gc_mark (s->dynwinds);
  83   scm_gc_mark (s->continuation_stack);
  84   scm_gc_mark (s->continuation_stack_ptr);
  85   scm_gc_mark (s->progargs);
  86   scm_gc_mark (s->exitval);
  87   scm_gc_mark (s->cur_inp);
  88   scm_gc_mark (s->cur_outp);
  89   scm_gc_mark (s->cur_errp);
  90   scm_gc_mark (s->def_inp);
  91   scm_gc_mark (s->def_outp);
  92   scm_gc_mark (s->def_errp);
  93   /* No need to gc mark def_loadp */
  94   scm_gc_mark (s->fluids);
  95   scm_gc_mark (s->top_level_lookup_closure_var);
  96   scm_gc_mark (s->system_transformer);
  97   return SCM_ROOT_STATE (root) -> parent;
  98 }
  99
 100
 101 static int print_root SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
 102
 103 static int
 104 print_root (exp, port, pstate)
 105      SCM exp;
 106      SCM port;
 107      scm_print_state *pstate;
 108 {
 109   scm_puts ("#<root ", port);
 110   scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
 111   scm_putc('>', port);
 112   return 1;
 113 }
 114
 115
 116 \f
 117
 118 SCM
 119 scm_make_root (parent)
 120      SCM parent;
 121 {
 122   SCM root;
 123   scm_root_state *root_state;
 124
 125   root_state = (scm_root_state *) scm_must_malloc (sizeof (scm_root_state),
 126                                                    "scm_make_root");
 127   if (SCM_NIMP (parent) && SCM_ROOTP (parent))
 128     {
 129       memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state));
 130       scm_copy_fluids (root_state);
 131       root_state->parent = parent;
 132     }
 133   else
 134     {
 135       root_state->parent = SCM_BOOL_F;
 136
 137       /* Initialize everything right now, in case a GC happens early.  */
 138       root_state->rootcont
 139         = root_state->dynwinds
 140         = root_state->continuation_stack
 141         = root_state->continuation_stack_ptr
 142         = root_state->progargs
 143         = root_state->exitval
 144         = root_state->cur_inp
 145         = root_state->cur_outp
 146         = root_state->cur_errp
 147         = root_state->def_inp
 148         = root_state->def_outp
 149         = root_state->def_errp
 150         = root_state->cur_loadp
 151         = root_state->fluids
 152         = root_state->system_transformer
 153         = root_state->top_level_lookup_closure_var
 154         = root_state->handle
 155         = root_state->parent
 156         = SCM_BOOL_F;
 157     }
 158   SCM_REDEFER_INTS;
 159   SCM_NEWSMOB (root, scm_tc16_root, root_state);
 160   root_state->handle = root;
 161   SCM_REALLOW_INTS;
 162   return root;
 163 }
 164
 165 /* {call-with-dynamic-root}
 166  *
 167  * Suspending the current thread to evaluate a thunk on the
 168  * same C stack but under a new root.
 169  *
 170  * Calls to call-with-dynamic-root return exactly once (unless
 171  * the process is somehow exitted).  */
 172
 173 /* Some questions about cwdr:
 174
 175    Couldn't the body just be a closure?  Do we really need to pass
 176    args through to it?
 177
 178    The semantics are a lot like catch's; in fact, we call
 179    scm_internal_catch to take care of that part of things.  Wouldn't
 180    it be cleaner to say that uncaught throws just disappear into the
 181    ether (or print a message to stderr), and let the caller use catch
 182    themselves if they want to?
 183
 184    -JimB */
 185
 186 #if 0
 187 SCM scm_exitval;                /* INUM with return value */
 188 #endif
 189 static int n_dynamic_roots = 0;
 190
 191
 192 /* cwdr fills out both of these structures, and then passes a pointer
 193    to them through scm_internal_catch to the cwdr_body and
 194    cwdr_handler functions, to tell them how to behave and to get
 195    information back from them.
 196
 197    A cwdr is a lot like a catch, except there is no tag (all
 198    exceptions are caught), and the body procedure takes the arguments
 199    passed to cwdr as A1 and ARGS.  The handler is also special since
 200    it is not directly run from scm_internal_catch.  It is executed
 201    outside the new dynamic root. */
 202
 203 struct cwdr_body_data {
 204   /* Arguments to pass to the cwdr body function.  */
 205   SCM a1, args;
 206
 207   /* Scheme procedure to use as body of cwdr.  */
 208   SCM body_proc;
 209 };
 210
 211 struct cwdr_handler_data {
 212   /* Do we need to run the handler? */
 213   int run_handler;
 214
 215   /* The tag and args to pass it. */
 216   SCM tag, args;
 217 };
 218
 219
 220 /* Invoke the body of a cwdr, assuming that the throw handler has
 221    already been set up.  DATA points to a struct set up by cwdr that
 222    says what proc to call, and what args to apply it to.
 223
 224    With a little thought, we could replace this with scm_body_thunk,
 225    but I don't want to mess with that at the moment.  */
 226 static SCM
 227 cwdr_body (void *data)
 228 {
 229   struct cwdr_body_data *c = (struct cwdr_body_data *) data;
 230
 231   return scm_apply (c->body_proc, c->a1, c->args);
 232 }
 233
 234 /* Record the fact that the body of the cwdr has thrown.  Record
 235    enough information to invoke the handler later when the dynamic
 236    root has been deestablished.  */
 237
 238 static SCM
 239 cwdr_handler (void *data, SCM tag, SCM args)
 240 {
 241   struct cwdr_handler_data *c = (struct cwdr_handler_data *) data;
 242
 243   c->run_handler = 1;
 244   c->tag = tag;
 245   c->args = args;
 246   return SCM_UNSPECIFIED;
 247 }
 248
 249 /* This is the basic code for new root creation.
 250  *
 251  * WARNING!  The order of actions in this routine is in many ways
 252  * critical.  E. g., it is essential that an error doesn't leave Guile
 253  * in a messed up state.  */
 254
 255 SCM
 256 scm_internal_cwdr (scm_catch_body_t body, void *body_data,
 257                    scm_catch_handler_t handler, void *handler_data,
 258                    SCM_STACKITEM *stack_start)
 259 {
 260 #ifdef USE_STACKJMPBUF
 261   scm_contregs static_jmpbuf;
 262 #endif
 263   int old_ints_disabled = scm_ints_disabled;
 264   SCM old_rootcont, old_winds;
 265   struct cwdr_handler_data my_handler_data;
 266   SCM answer;
 267
 268   /* Create a fresh root continuation.  */
 269   {
 270     SCM new_rootcont;
 271     SCM_NEWCELL (new_rootcont);
 272     SCM_REDEFER_INTS;
 273 #ifdef USE_STACKJMPBUF
 274     SCM_SETJMPBUF (new_rootcont, &static_jmpbuf);
 275 #else
 276     SCM_SETJMPBUF (new_rootcont,
 277                    scm_must_malloc ((long) sizeof (scm_contregs),
 278                                     "inferior root continuation"));
 279 #endif
 280     SCM_SETCAR (new_rootcont, scm_tc7_contin);
 281     SCM_DYNENV (new_rootcont) = SCM_EOL;
 282     SCM_BASE (new_rootcont) = stack_start;
 283     SCM_SEQ (new_rootcont) = ++n_dynamic_roots;
 284 #ifdef DEBUG_EXTENSIONS
 285     SCM_DFRAME (new_rootcont) = 0;
 286 #endif
 287     old_rootcont = scm_rootcont;
 288     scm_rootcont = new_rootcont;
 289     SCM_REALLOW_INTS;
 290   }
 291
 292   /* Exit caller's dynamic state.
 293    */
 294   old_winds = scm_dynwinds;
 295   scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
 296 #ifdef DEBUG_EXTENSIONS
 297   SCM_DFRAME (old_rootcont) = scm_last_debug_frame;
 298   scm_last_debug_frame = 0;
 299 #endif
 300
 301   {
 302     my_handler_data.run_handler = 0;
 303     answer = scm_internal_catch (SCM_BOOL_T,
 304                                  body, body_data,
 305                                  cwdr_handler, &my_handler_data);
 306   }
 307
 308   scm_dowinds (old_winds, - scm_ilength (old_winds));
 309   SCM_REDEFER_INTS;
 310 #ifdef USE_STACKCJMPBUF
 311   SCM_SETJMPBUF (scm_rootcont, NULL);
 312 #endif
 313 #ifdef DEBUG_EXTENSIONS
 314   scm_last_debug_frame = SCM_DFRAME (old_rootcont);
 315 #endif
 316   scm_rootcont = old_rootcont;
 317   SCM_REALLOW_INTS;
 318   scm_ints_disabled = old_ints_disabled;
 319
 320   /* Now run the real handler iff the body did a throw. */
 321   if (my_handler_data.run_handler)
 322     return handler (handler_data, my_handler_data.tag, my_handler_data.args);
 323   else
 324     return answer;
 325 }
 326
 327 /* The original CWDR for invoking Scheme code with a Scheme handler. */
 328
 329 static SCM
 330 cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)
 331 {
 332   struct cwdr_body_data c;
 333
 334   c.a1 = a1;
 335   c.args = args;
 336   c.body_proc = proc;
 337
 338   return scm_internal_cwdr (cwdr_body, &c,
 339                             scm_handle_by_proc, &handler,
 340                             stack_start);
 341 }
 342
 343 SCM_PROC(s_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, scm_call_with_dynamic_root);
 344 SCM
 345 scm_call_with_dynamic_root (thunk, handler)
 346      SCM thunk;
 347      SCM handler;
 348 {
 349   SCM_STACKITEM stack_place;
 350
 351   return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
 352 }
 353
 354 SCM_PROC(s_dynamic_root, "dynamic-root", 0, 0, 0, scm_dynamic_root);
 355 SCM
 356 scm_dynamic_root ()
 357 {
 358   return scm_ulong2num (SCM_SEQ (scm_root->rootcont));
 359 }
 360
 361 SCM
 362 scm_apply_with_dynamic_root (proc, a1, args, handler)
 363      SCM proc;
 364      SCM a1;
 365      SCM args;
 366      SCM handler;
 367 {
 368   SCM_STACKITEM stack_place;
 369   return cwdr (proc, a1, args, handler, &stack_place);
 370 }
 371
 372 \f
 373
 374 /* Call thunk(closure) underneath a top-level error handler.
 375  * If an error occurs, pass the exitval through err_filter and return it.
 376  * If no error occurs, return the value of thunk.
 377  */
 378
 379
 380 #ifdef _UNICOS
 381 typedef int setjmp_type;
 382 #else
 383 typedef long setjmp_type;
 384 #endif
 385
 386
 387
 388 SCM
 389 scm_call_catching_errors (thunk, err_filter, closure)
 390      SCM (*thunk)();
 391      SCM (*err_filter)();
 392      void *closure;
 393 {
 394   SCM answer;
 395   setjmp_type i;
 396 #ifdef DEBUG_EXTENSIONS
 397   SCM_DFRAME (scm_rootcont) = scm_last_debug_frame;
 398 #endif
 399   i = setjmp (SCM_JMPBUF (scm_rootcont));
 400   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 401   if (!i)
 402     {
 403       scm_gc_heap_lock = 0;
 404       answer = thunk (closure);
 405     }
 406   else
 407     {
 408       scm_gc_heap_lock = 1;
 409       answer = err_filter (scm_exitval, closure);
 410     }
 411   return answer;
 412 }
 413
 414 void
 415 scm_init_root ()
 416 {
 417   scm_tc16_root = scm_make_smob_type_mfpe ("root", sizeof (struct scm_root_state),
 418                                           mark_root, NULL, print_root, NULL);
 419
 420 #include "root.x"
 421 }