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
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include <stdio.h>
  48 #include "_scm.h"
  49 #include "stackchk.h"
  50 #include "dynwind.h"
  51 #include "eval.h"
  52 #include "genio.h"
  53 #include "smob.h"
  54 #include "pairs.h"
  55 #include "throw.h"
  56 #include "fluids.h"
  57
  58 #include "root.h"
  59 \f
  60
  61 /* Define this if you want to try out the stack allocation of cwdr's
  62    jumpbuf.  It works for me but I'm still worried that the dynwinds
  63    might be able to make a mess. */
  64
  65 #undef USE_STACKJMPBUF
  66
  67 SCM scm_sys_protects[SCM_NUM_PROTECTS];
  68
  69 long scm_tc16_root;
  70
  71 #ifndef USE_THREADS
  72 struct scm_root_state *scm_root;
  73 #endif
  74
  75 \f
  76
  77 static SCM
  78 mark_root (SCM root)
  79 {
  80   scm_root_state *s = SCM_ROOT_STATE (root);
  81
  82   scm_gc_mark (s->rootcont);
  83   scm_gc_mark (s->dynwinds);
  84   scm_gc_mark (s->continuation_stack);
  85   scm_gc_mark (s->continuation_stack_ptr);
  86   scm_gc_mark (s->progargs);
  87   scm_gc_mark (s->exitval);
  88   scm_gc_mark (s->cur_inp);
  89   scm_gc_mark (s->cur_outp);
  90   scm_gc_mark (s->cur_errp);
  91   scm_gc_mark (s->def_inp);
  92   scm_gc_mark (s->def_outp);
  93   scm_gc_mark (s->def_errp);
  94   /* No need to gc mark def_loadp */
  95   scm_gc_mark (s->fluids);
  96   scm_gc_mark (s->top_level_lookup_closure_var);
  97   scm_gc_mark (s->system_transformer);
  98   return SCM_ROOT_STATE (root) -> parent;
  99 }
 100
 101
 102 static int
 103 print_root (SCM exp,SCM port,scm_print_state *pstate)
 104 {
 105   scm_puts ("#<root ", port);
 106   scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
 107   scm_putc('>', port);
 108   return 1;
 109 }
 110
 111
 112 \f
 113
 114 SCM
 115 scm_make_root (SCM parent)
 116 {
 117   SCM root;
 118   scm_root_state *root_state;
 119
 120   root_state = (scm_root_state *) scm_must_malloc (sizeof (scm_root_state),
 121                                                    "scm_make_root");
 122   if (SCM_ROOTP (parent))
 123     {
 124       memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state));
 125       scm_copy_fluids (root_state);
 126       root_state->parent = parent;
 127     }
 128   else
 129     {
 130       root_state->parent = SCM_BOOL_F;
 131
 132       /* Initialize everything right now, in case a GC happens early.  */
 133       root_state->rootcont
 134         = root_state->dynwinds
 135         = root_state->continuation_stack
 136         = root_state->continuation_stack_ptr
 137         = root_state->progargs
 138         = root_state->exitval
 139         = root_state->cur_inp
 140         = root_state->cur_outp
 141         = root_state->cur_errp
 142         = root_state->def_inp
 143         = root_state->def_outp
 144         = root_state->def_errp
 145         = root_state->cur_loadp
 146         = root_state->fluids
 147         = root_state->system_transformer
 148         = root_state->top_level_lookup_closure_var
 149         = root_state->handle
 150         = root_state->parent
 151         = SCM_BOOL_F;
 152     }
 153   SCM_REDEFER_INTS;
 154   SCM_NEWSMOB (root, scm_tc16_root, root_state);
 155   root_state->handle = root;
 156   SCM_REALLOW_INTS;
 157   return root;
 158 }
 159
 160 /* {call-with-dynamic-root}
 161  *
 162  * Suspending the current thread to evaluate a thunk on the
 163  * same C stack but under a new root.
 164  *
 165  * Calls to call-with-dynamic-root return exactly once (unless
 166  * the process is somehow exitted).  */
 167
 168 /* Some questions about cwdr:
 169
 170    Couldn't the body just be a closure?  Do we really need to pass
 171    args through to it?
 172
 173    The semantics are a lot like catch's; in fact, we call
 174    scm_internal_catch to take care of that part of things.  Wouldn't
 175    it be cleaner to say that uncaught throws just disappear into the
 176    ether (or print a message to stderr), and let the caller use catch
 177    themselves if they want to?
 178
 179    -JimB */
 180
 181 #if 0
 182 SCM scm_exitval;                /* INUM with return value */
 183 #endif
 184 static int n_dynamic_roots = 0;
 185
 186
 187 /* cwdr fills out both of these structures, and then passes a pointer
 188    to them through scm_internal_catch to the cwdr_body and
 189    cwdr_handler functions, to tell them how to behave and to get
 190    information back from them.
 191
 192    A cwdr is a lot like a catch, except there is no tag (all
 193    exceptions are caught), and the body procedure takes the arguments
 194    passed to cwdr as A1 and ARGS.  The handler is also special since
 195    it is not directly run from scm_internal_catch.  It is executed
 196    outside the new dynamic root. */
 197
 198 struct cwdr_body_data {
 199   /* Arguments to pass to the cwdr body function.  */
 200   SCM a1, args;
 201
 202   /* Scheme procedure to use as body of cwdr.  */
 203   SCM body_proc;
 204 };
 205
 206 struct cwdr_handler_data {
 207   /* Do we need to run the handler? */
 208   int run_handler;
 209
 210   /* The tag and args to pass it. */
 211   SCM tag, args;
 212 };
 213
 214
 215 /* Invoke the body of a cwdr, assuming that the throw handler has
 216    already been set up.  DATA points to a struct set up by cwdr that
 217    says what proc to call, and what args to apply it to.
 218
 219    With a little thought, we could replace this with scm_body_thunk,
 220    but I don't want to mess with that at the moment.  */
 221 static SCM
 222 cwdr_body (void *data)
 223 {
 224   struct cwdr_body_data *c = (struct cwdr_body_data *) data;
 225
 226   return scm_apply (c->body_proc, c->a1, c->args);
 227 }
 228
 229 /* Record the fact that the body of the cwdr has thrown.  Record
 230    enough information to invoke the handler later when the dynamic
 231    root has been deestablished.  */
 232
 233 static SCM
 234 cwdr_handler (void *data, SCM tag, SCM args)
 235 {
 236   struct cwdr_handler_data *c = (struct cwdr_handler_data *) data;
 237
 238   c->run_handler = 1;
 239   c->tag = tag;
 240   c->args = args;
 241   return SCM_UNSPECIFIED;
 242 }
 243
 244 /* This is the basic code for new root creation.
 245  *
 246  * WARNING!  The order of actions in this routine is in many ways
 247  * critical.  E. g., it is essential that an error doesn't leave Guile
 248  * in a messed up state.  */
 249
 250 SCM
 251 scm_internal_cwdr (scm_catch_body_t body, void *body_data,
 252                    scm_catch_handler_t handler, void *handler_data,
 253                    SCM_STACKITEM *stack_start)
 254 {
 255 #ifdef USE_STACKJMPBUF
 256   scm_contregs static_jmpbuf;
 257 #endif
 258   int old_ints_disabled = scm_ints_disabled;
 259   SCM old_rootcont, old_winds;
 260   struct cwdr_handler_data my_handler_data;
 261   SCM answer;
 262
 263   /* Create a fresh root continuation.  */
 264   {
 265     SCM new_rootcont;
 266     SCM_NEWCELL (new_rootcont);
 267     SCM_REDEFER_INTS;
 268 #ifdef USE_STACKJMPBUF
 269     SCM_SETJMPBUF (new_rootcont, &static_jmpbuf);
 270 #else
 271     SCM_SETJMPBUF (new_rootcont,
 272                    scm_must_malloc ((long) sizeof (scm_contregs),
 273                                     "inferior root continuation"));
 274 #endif
 275     SCM_SETCAR (new_rootcont, scm_tc7_contin);
 276     SCM_DYNENV (new_rootcont) = SCM_EOL;
 277     SCM_BASE (new_rootcont) = stack_start;
 278     SCM_SEQ (new_rootcont) = ++n_dynamic_roots;
 279 #ifdef DEBUG_EXTENSIONS
 280     SCM_DFRAME (new_rootcont) = 0;
 281 #endif
 282     old_rootcont = scm_rootcont;
 283     scm_rootcont = new_rootcont;
 284     SCM_REALLOW_INTS;
 285   }
 286
 287   /* Exit caller's dynamic state.
 288    */
 289   old_winds = scm_dynwinds;
 290   scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
 291 #ifdef DEBUG_EXTENSIONS
 292   SCM_DFRAME (old_rootcont) = scm_last_debug_frame;
 293   scm_last_debug_frame = 0;
 294 #endif
 295
 296   {
 297     my_handler_data.run_handler = 0;
 298     answer = scm_internal_catch (SCM_BOOL_T,
 299                                  body, body_data,
 300                                  cwdr_handler, &my_handler_data);
 301   }
 302
 303   scm_dowinds (old_winds, - scm_ilength (old_winds));
 304   SCM_REDEFER_INTS;
 305 #ifdef USE_STACKCJMPBUF
 306   SCM_SETJMPBUF (scm_rootcont, NULL);
 307 #endif
 308 #ifdef DEBUG_EXTENSIONS
 309   scm_last_debug_frame = SCM_DFRAME (old_rootcont);
 310 #endif
 311   scm_rootcont = old_rootcont;
 312   SCM_REALLOW_INTS;
 313   scm_ints_disabled = old_ints_disabled;
 314
 315   /* Now run the real handler iff the body did a throw. */
 316   if (my_handler_data.run_handler)
 317     return handler (handler_data, my_handler_data.tag, my_handler_data.args);
 318   else
 319     return answer;
 320 }
 321
 322 /* The original CWDR for invoking Scheme code with a Scheme handler. */
 323
 324 static SCM
 325 cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)
 326 {
 327   struct cwdr_body_data c;
 328
 329   c.a1 = a1;
 330   c.args = args;
 331   c.body_proc = proc;
 332
 333   return scm_internal_cwdr (cwdr_body, &c,
 334                             scm_handle_by_proc, &handler,
 335                             stack_start);
 336 }
 337
 338 SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0,
 339            (SCM thunk, SCM handler),
 340             "Evaluate @var{(thunk)} in a new dynamic context, returning its value.\n\n"
 341             "If an error occurs during evaluation, apply @var{handler} to the\n"
 342             "arguments to the throw, just as @code{throw} would.  If this happens,\n"
 343             "@var{handler} is called outside the scope of the new root -- it is\n"
 344             "called in the same dynamic context in which\n"
 345             "@code{call-with-dynamic-root} was evaluated.\n\n"
 346             "If @var{thunk} captures a continuation, the continuation is rooted at\n"
 347             "the call to @var{thunk}.  In particular, the call to\n"
 348             "@code{call-with-dynamic-root} is not captured.  Therefore,\n"
 349             "@code{call-with-dynamic-root} always returns at most one time.\n\n"
 350             "Before calling @var{thunk}, the dynamic-wind chain is un-wound back to\n"
 351             "the root and a new chain started for @var{thunk}.  Therefore, this call\n"
 352             "may not do what you expect:\n\n"
 353             "@example\n"
 354             ";; Almost certainly a bug:\n"
 355             "(with-output-to-port\n"
 356             " some-port\n\n"
 357             " (lambda ()\n"
 358             "   (call-with-dynamic-root\n"
 359             "    (lambda ()\n"
 360             "      (display 'fnord)\n"
 361             "      (newline))\n"
 362             "    (lambda (errcode) errcode))))\n"
 363             "@end example\n\n"
 364             "The problem is, on what port will @samp{fnord\n"
 365             "} be displayed?  You\n"
 366             "might expect that because of the @code{with-output-to-port} that\n"
 367             "it will be displayed on the port bound to @code{some-port}.  But it\n"
 368             "probably won't -- before evaluating the thunk, dynamic winds are\n"
 369             "unwound, including those created by @code{with-output-to-port}.\n"
 370             "So, the standard output port will have been re-set to its default value\n"
 371             "before @code{display} is evaluated.\n\n"
 372             "(This function was added to Guile mostly to help calls to functions in C\n"
 373             "libraries that can not tolerate non-local exits or calls that return\n"
 374             "multiple times.  If such functions call back to the interpreter, it should\n"
 375             "be under a new dynamic root.)")
 376 #define FUNC_NAME s_scm_call_with_dynamic_root
 377 {
 378   SCM_STACKITEM stack_place;
 379   return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
 380 }
 381 #undef FUNC_NAME
 382
 383 SCM_DEFINE (scm_dynamic_root, "dynamic-root", 0, 0, 0,
 384            (),
 385             "Return an object representing the current dynamic root.\n\n"
 386             "These objects are only useful for comparison using @code{eq?}.\n"
 387             "They are currently represented as numbers, but your code should\n"
 388             "in no way depend on this.")
 389 #define FUNC_NAME s_scm_dynamic_root
 390 {
 391   return scm_ulong2num (SCM_SEQ (scm_root->rootcont));
 392 }
 393 #undef FUNC_NAME
 394
 395 SCM
 396 scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler)
 397 {
 398   SCM_STACKITEM stack_place;
 399   return cwdr (proc, a1, args, handler, &stack_place);
 400 }
 401
 402 \f
 403
 404 /* Call thunk(closure) underneath a top-level error handler.
 405  * If an error occurs, pass the exitval through err_filter and return it.
 406  * If no error occurs, return the value of thunk.
 407  */
 408
 409
 410 #ifdef _UNICOS
 411 typedef int setjmp_type;
 412 #else
 413 typedef long setjmp_type;
 414 #endif
 415
 416
 417
 418 SCM
 419 scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void *closure)
 420 {
 421   SCM answer;
 422   setjmp_type i;
 423 #ifdef DEBUG_EXTENSIONS
 424   SCM_DFRAME (scm_rootcont) = scm_last_debug_frame;
 425 #endif
 426   i = setjmp (SCM_JMPBUF (scm_rootcont));
 427   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 428   if (!i)
 429     {
 430       scm_gc_heap_lock = 0;
 431       answer = thunk (closure);
 432     }
 433   else
 434     {
 435       scm_gc_heap_lock = 1;
 436       answer = err_filter (scm_exitval, closure);
 437     }
 438   return answer;
 439 }
 440
 441 void
 442 scm_init_root ()
 443 {
 444   scm_tc16_root = scm_make_smob_type_mfpe ("root", sizeof (struct scm_root_state),
 445                                           mark_root, NULL, print_root, NULL);
 446
 447 #include "root.x"
 448 }