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