libguile/root.c

   1 /*      Copyright (C) 1995,1996, 1997 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   SCM_SETGC8MARK (root);
  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   scm_gc_mark (s->fluids);
  94   scm_gc_mark (s->top_level_lookup_closure_var);
  95   scm_gc_mark (s->system_transformer);
  96   return SCM_ROOT_STATE (root) -> parent;
  97 }
  98
  99 static scm_sizet free_root SCM_P ((SCM));
 100
 101 static scm_sizet
 102 free_root (root)
 103      SCM root;
 104 {
 105   scm_must_free ((char *) SCM_ROOT_STATE (root));
 106   return sizeof (scm_root_state);
 107 }
 108
 109 static int print_root SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
 110
 111 static int
 112 print_root (exp, port, pstate)
 113      SCM exp;
 114      SCM port;
 115      scm_print_state *pstate;
 116 {
 117   scm_puts ("#<root ", port);
 118   scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
 119   scm_putc('>', port);
 120   return 1;
 121 }
 122
 123 static scm_smobfuns root_smob =
 124 {
 125   mark_root,
 126   free_root,
 127   print_root,
 128   0
 129 };
 130
 131 \f
 132
 133 SCM
 134 scm_make_root (parent)
 135      SCM parent;
 136 {
 137   SCM root;
 138   scm_root_state *root_state;
 139
 140   root_state = (scm_root_state *) scm_must_malloc (sizeof (scm_root_state),
 141                                                    "scm_make_root");
 142   if (SCM_NIMP (parent) && SCM_ROOTP (parent))
 143     {
 144       memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state));
 145       scm_copy_fluids (root_state);
 146       root_state->parent = parent;
 147     }
 148   else
 149     {
 150       root_state->parent = SCM_BOOL_F;
 151     }
 152   SCM_NEWCELL (root);
 153   SCM_REDEFER_INTS;
 154   SCM_SETCAR (root, scm_tc16_root);
 155   SCM_SETCDR (root, root_state);
 156   root_state->handle = root;
 157   SCM_REALLOW_INTS;
 158   return root;
 159 }
 160
 161 /* {call-with-dynamic-root}
 162  *
 163  * Suspending the current thread to evaluate a thunk on the
 164  * same C stack but under a new root.
 165  *
 166  * Calls to call-with-dynamic-root return exactly once (unless
 167  * the process is somehow exitted).  */
 168
 169 /* Some questions about cwdr:
 170
 171    Couldn't the body just be a closure?  Do we really need to pass
 172    args through to it?
 173
 174    The semantics are a lot like catch's; in fact, we call
 175    scm_internal_catch to take care of that part of things.  Wouldn't
 176    it be cleaner to say that uncaught throws just disappear into the
 177    ether (or print a message to stderr), and let the caller use catch
 178    themselves if they want to?
 179
 180    -JimB */
 181
 182 #if 0
 183 SCM scm_exitval;                /* INUM with return value */
 184 #endif
 185 static int n_dynamic_roots = 0;
 186
 187
 188 /* cwdr fills out both of these structures, and then passes a pointer
 189    to them through scm_internal_catch to the cwdr_body and
 190    cwdr_handler functions, to tell them how to behave and to get
 191    information back from them.
 192
 193    A cwdr is a lot like a catch, except there is no tag (all
 194    exceptions are caught), and the body procedure takes the arguments
 195    passed to cwdr as A1 and ARGS.  The handler is also special since
 196    it is not directly run from scm_internal_catch.  It is executed
 197    outside the new dynamic root. */
 198
 199 struct cwdr_body_data {
 200   /* Arguments to pass to the cwdr body function.  */
 201   SCM a1, args;
 202
 203   /* Scheme procedure to use as body of cwdr.  */
 204   SCM body_proc;
 205 };
 206
 207 struct cwdr_handler_data {
 208   /* Do we need to run the handler? */
 209   int run_handler;
 210
 211   /* The tag and args to pass it. */
 212   SCM tag, args;
 213 };
 214
 215
 216 /* Invoke the body of a cwdr, assuming that the throw handler has
 217    already been set up.  DATA points to a struct set up by cwdr that
 218    says what proc to call, and what args to apply it to.
 219
 220    With a little thought, we could replace this with scm_body_thunk,
 221    but I don't want to mess with that at the moment.  */
 222 static SCM
 223 cwdr_body (void *data, SCM jmpbuf)
 224 {
 225   struct cwdr_body_data *c = (struct cwdr_body_data *) data;
 226
 227   return scm_apply (c->body_proc, c->a1, c->args);
 228 }
 229
 230 /* Record the fact that the body of the cwdr has thrown.  Record
 231    enough information to invoke the handler later when the dynamic
 232    root has been deestablished.  */
 233
 234 static SCM
 235 cwdr_handler (void *data, SCM tag, SCM args)
 236 {
 237   struct cwdr_handler_data *c = (struct cwdr_handler_data *) data;
 238
 239   c->run_handler = 1;
 240   c->tag = tag;
 241   c->args = args;
 242   return SCM_UNSPECIFIED;
 243 }
 244
 245 /* This is the basic code for new root creation.
 246  *
 247  * WARNING!  The order of actions in this routine is in many ways
 248  * critical.  E. g., it is essential that an error doesn't leave Guile
 249  * in a messed up state.  */
 250
 251 SCM
 252 scm_internal_cwdr (scm_catch_body_t body, void *body_data,
 253                    scm_catch_handler_t handler, void *handler_data,
 254                    SCM_STACKITEM *stack_start)
 255 {
 256 #ifdef USE_STACKJMPBUF
 257   scm_contregs static_jmpbuf;
 258 #endif
 259   int old_ints_disabled = scm_ints_disabled;
 260   SCM old_rootcont, old_winds;
 261   struct cwdr_handler_data my_handler_data;
 262   SCM answer;
 263
 264   /* Create a fresh root continuation.  */
 265   {
 266     SCM new_rootcont;
 267     SCM_NEWCELL (new_rootcont);
 268     SCM_REDEFER_INTS;
 269 #ifdef USE_STACKJMPBUF
 270     SCM_SETJMPBUF (new_rootcont, &static_jmpbuf);
 271 #else
 272     SCM_SETJMPBUF (new_rootcont,
 273                    scm_must_malloc ((long) sizeof (scm_contregs),
 274                                     "inferior root continuation"));
 275 #endif
 276     SCM_SETCAR (new_rootcont, scm_tc7_contin);
 277     SCM_DYNENV (new_rootcont) = SCM_EOL;
 278     SCM_BASE (new_rootcont) = stack_start;
 279     SCM_SEQ (new_rootcont) = ++n_dynamic_roots;
 280 #ifdef DEBUG_EXTENSIONS
 281     SCM_DFRAME (new_rootcont) = 0;
 282 #endif
 283     old_rootcont = scm_rootcont;
 284     scm_rootcont = new_rootcont;
 285     SCM_REALLOW_INTS;
 286   }
 287
 288   /* Exit caller's dynamic state.
 289    */
 290   old_winds = scm_dynwinds;
 291   scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
 292 #ifdef DEBUG_EXTENSIONS
 293   SCM_DFRAME (old_rootcont) = scm_last_debug_frame;
 294   scm_last_debug_frame = 0;
 295 #endif
 296
 297   {
 298     my_handler_data.run_handler = 0;
 299     answer = scm_internal_catch (SCM_BOOL_T,
 300                                  body, body_data,
 301                                  cwdr_handler, &my_handler_data);
 302   }
 303
 304   scm_dowinds (old_winds, - scm_ilength (old_winds));
 305   SCM_REDEFER_INTS;
 306 #ifdef USE_STACKCJMPBUF
 307   SCM_SETJMPBUF (scm_rootcont, NULL);
 308 #endif
 309 #ifdef DEBUG_EXTENSIONS
 310   scm_last_debug_frame = SCM_DFRAME (old_rootcont);
 311 #endif
 312   scm_rootcont = old_rootcont;
 313   SCM_REALLOW_INTS;
 314   scm_ints_disabled = old_ints_disabled;
 315
 316   /* Now run the real handler iff the body did a throw. */
 317   if (my_handler_data.run_handler)
 318     return handler (handler_data, my_handler_data.tag, my_handler_data.args);
 319   else
 320     return answer;
 321 }
 322
 323 /* The original CWDR for invoking Scheme code with a Scheme handler. */
 324
 325 static SCM
 326 cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)
 327 {
 328   struct cwdr_body_data c;
 329
 330   c.a1 = a1;
 331   c.args = args;
 332   c.body_proc = proc;
 333
 334   return scm_internal_cwdr (cwdr_body, &c,
 335                             scm_handle_by_proc, &handler,
 336                             stack_start);
 337 }
 338
 339 SCM_PROC(s_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, scm_call_with_dynamic_root);
 340 SCM
 341 scm_call_with_dynamic_root (thunk, handler)
 342      SCM thunk;
 343      SCM handler;
 344 {
 345   SCM_STACKITEM stack_place;
 346
 347   return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
 348 }
 349
 350 SCM_PROC(s_dynamic_root, "dynamic-root", 0, 0, 0, scm_dynamic_root);
 351 SCM
 352 scm_dynamic_root ()
 353 {
 354   return scm_ulong2num (SCM_SEQ (scm_root->rootcont));
 355 }
 356
 357 SCM
 358 scm_apply_with_dynamic_root (proc, a1, args, handler)
 359      SCM proc;
 360      SCM a1;
 361      SCM args;
 362      SCM handler;
 363 {
 364   SCM_STACKITEM stack_place;
 365   return cwdr (proc, a1, args, handler, &stack_place);
 366 }
 367
 368 \f
 369
 370 /* Call thunk(closure) underneath a top-level error handler.
 371  * If an error occurs, pass the exitval through err_filter and return it.
 372  * If no error occurs, return the value of thunk.
 373  */
 374
 375
 376 #ifdef _UNICOS
 377 typedef int setjmp_type;
 378 #else
 379 typedef long setjmp_type;
 380 #endif
 381
 382
 383
 384 SCM
 385 scm_call_catching_errors (thunk, err_filter, closure)
 386      SCM (*thunk)();
 387      SCM (*err_filter)();
 388      void *closure;
 389 {
 390   SCM answer;
 391   setjmp_type i;
 392 #ifdef DEBUG_EXTENSIONS
 393   SCM_DFRAME (scm_rootcont) = scm_last_debug_frame;
 394 #endif
 395   i = setjmp (SCM_JMPBUF (scm_rootcont));
 396   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 397   if (!i)
 398     {
 399       scm_gc_heap_lock = 0;
 400       answer = thunk (closure);
 401     }
 402   else
 403     {
 404       scm_gc_heap_lock = 1;
 405       answer = err_filter (scm_exitval, closure);
 406     }
 407   return answer;
 408 }
 409
 410 void
 411 scm_init_root ()
 412 {
 413   scm_tc16_root = scm_newsmob (&root_smob);
 414 #include "root.x"
 415 }