libguile/root.c

   1 /*      Copyright (C) 1995,1996 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, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  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
  53 #include "root.h"
  54 \f
  55
  56 SCM scm_sys_protects[SCM_NUM_PROTECTS];
  57
  58 long scm_tc16_root;
  59
  60 #ifndef USE_THREADS
  61 struct scm_root_state *scm_root;
  62 #endif
  63
  64 \f
  65
  66 static SCM mark_root SCM_P ((SCM));
  67
  68 static SCM
  69 mark_root (root)
  70      SCM root;
  71 {
  72   scm_root_state *s = SCM_ROOT_STATE (root);
  73   SCM_SETGC8MARK (root);
  74   scm_gc_mark (s->rootcont);
  75   scm_gc_mark (s->dynwinds);
  76   scm_gc_mark (s->continuation_stack);
  77   scm_gc_mark (s->continuation_stack_ptr);
  78   scm_gc_mark (s->progargs);
  79   scm_gc_mark (s->exitval);
  80   scm_gc_mark (s->cur_inp);
  81   scm_gc_mark (s->cur_outp);
  82   scm_gc_mark (s->cur_errp);
  83   scm_gc_mark (s->def_inp);
  84   scm_gc_mark (s->def_outp);
  85   scm_gc_mark (s->def_errp);
  86   scm_gc_mark (s->top_level_lookup_thunk_var);
  87   scm_gc_mark (s->system_transformer);
  88   return SCM_ROOT_STATE (root) -> parent;
  89 }
  90
  91 static scm_sizet free_root SCM_P ((SCM));
  92
  93 static scm_sizet
  94 free_root (root)
  95      SCM root;
  96 {
  97   scm_must_free ((char *) SCM_ROOT_STATE (root));
  98   return sizeof (scm_root_state);
  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_gen_puts (scm_regular_string, "#<root ", port);
 110   scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
 111   scm_gen_putc('>', port);
 112   return 1;
 113 }
 114
 115 static scm_smobfuns root_smob =
 116 {
 117   mark_root,
 118   free_root,
 119   print_root,
 120   0
 121 };
 122
 123 \f
 124
 125 SCM
 126 scm_make_root (parent)
 127      SCM parent;
 128 {
 129   SCM root;
 130   scm_root_state *root_state;
 131
 132   root_state = (scm_root_state *) scm_must_malloc (sizeof (scm_root_state),
 133                                                    "scm_make_root");
 134   if (SCM_NIMP (parent) && SCM_ROOTP (parent))
 135     {
 136       memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state));
 137       root_state->parent = parent;
 138     }
 139   else
 140     {
 141       root_state->parent = SCM_BOOL_F;
 142     }
 143   SCM_NEWCELL (root);
 144   SCM_REDEFER_INTS;
 145   SCM_SETCAR (root, scm_tc16_root);
 146   SCM_SETCDR (root, root_state);
 147   root_state->handle = root;
 148   SCM_REALLOW_INTS;
 149   return root;
 150 }
 151
 152 /* {call-with-dynamic-root}
 153  *
 154  * Suspending the current thread to evaluate a thunk on the
 155  * same C stack but under a new root.
 156  *
 157  * Calls to call-with-dynamic-root return exactly once (unless
 158  * the process is somehow exitted).
 159  */
 160
 161 #if 0
 162 SCM scm_exitval;                /* INUM with return value */
 163 #endif
 164 static int n_dynamic_roots = 0;
 165
 166 static SCM cwdr SCM_P ((SCM thunk, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start));
 167
 168 /* This is the basic code for new root creation.
 169  *
 170  * WARNING!  The order of actions in this routine is in many ways
 171  * critical.  E. g., it is essential that an error doesn't leave Guile
 172  * in a messed up state.
 173  */
 174
 175 static SCM
 176 cwdr (proc, a1, args, handler, stack_start)
 177      SCM proc;
 178      SCM a1;
 179      SCM args;
 180      SCM handler;
 181      SCM_STACKITEM *stack_start;
 182 {
 183   int old_ints_disabled = scm_ints_disabled;
 184   SCM old_rootcont, old_winds;
 185   SCM answer;
 186
 187   /* Create a fresh root continuation.
 188    */
 189   {
 190     SCM new_rootcont;
 191     SCM_NEWCELL (new_rootcont);
 192     SCM_REDEFER_INTS;
 193     SCM_SETJMPBUF (new_rootcont,
 194                    scm_must_malloc ((long) sizeof (regs),
 195                                     "inferior root continuation"));
 196     SCM_CAR (new_rootcont) = scm_tc7_contin;
 197     SCM_DYNENV (new_rootcont) = SCM_EOL;
 198     SCM_BASE (new_rootcont) = stack_start;
 199     SCM_SEQ (new_rootcont) = ++n_dynamic_roots;
 200 #ifdef DEBUG_EXTENSIONS
 201     SCM_DFRAME (new_rootcont) = 0;
 202 #endif
 203     old_rootcont = scm_rootcont;
 204     scm_rootcont = new_rootcont;
 205     SCM_REALLOW_INTS;
 206   }
 207
 208   /* Exit caller's dynamic state.
 209    */
 210   old_winds = scm_dynwinds;
 211   scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
 212 #ifdef DEBUG_EXTENSIONS
 213   scm_last_debug_frame = 0;
 214 #endif
 215
 216   /* Catch all errors. */
 217   answer = scm_catch_apply (SCM_BOOL_T, proc, a1, args, handler);
 218
 219   scm_dowinds (old_winds, - scm_ilength (old_winds));
 220   SCM_REDEFER_INTS;
 221   scm_rootcont = old_rootcont;
 222 #ifdef DEBUG_EXTENSIONS
 223   scm_last_debug_frame = SCM_DFRAME (scm_rootcont);
 224 #endif
 225   SCM_REALLOW_INTS;
 226   scm_ints_disabled = old_ints_disabled;
 227   return answer;
 228 }
 229
 230
 231 SCM_PROC(s_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, scm_call_with_dynamic_root);
 232 SCM
 233 scm_call_with_dynamic_root (thunk, handler)
 234      SCM thunk;
 235      SCM handler;
 236 {
 237   SCM_STACKITEM stack_place;
 238
 239   return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
 240 }
 241
 242 SCM_PROC(s_dynamic_root, "dynamic-root", 0, 0, 0, scm_dynamic_root);
 243 SCM
 244 scm_dynamic_root ()
 245 {
 246   return scm_ulong2num (SCM_SEQ (scm_root->rootcont));
 247 }
 248
 249 SCM
 250 scm_apply_with_dynamic_root (proc, a1, args, handler)
 251      SCM proc;
 252      SCM a1;
 253      SCM args;
 254      SCM handler;
 255 {
 256   SCM_STACKITEM stack_place;
 257   return cwdr (proc, a1, args, handler, &stack_place);
 258 }
 259
 260 \f
 261
 262 /* Call thunk(closure) underneath a top-level error handler.
 263  * If an error occurs, pass the exitval through err_filter and return it.
 264  * If no error occurs, return the value of thunk.
 265  */
 266
 267
 268 #ifdef _UNICOS
 269 typedef int setjmp_type;
 270 #else
 271 typedef long setjmp_type;
 272 #endif
 273
 274
 275
 276 SCM
 277 scm_call_catching_errors (thunk, err_filter, closure)
 278      SCM (*thunk)();
 279      SCM (*err_filter)();
 280      void *closure;
 281 {
 282   SCM answer;
 283   setjmp_type i;
 284 #ifdef DEBUG_EXTENSIONS
 285   SCM_DFRAME (scm_rootcont) = scm_last_debug_frame;
 286 #endif
 287   i = setjmp (SCM_JMPBUF (scm_rootcont));
 288 #ifdef STACK_CHECKING
 289   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 290 #endif
 291   if (!i)
 292     {
 293       scm_gc_heap_lock = 0;
 294       answer = thunk (closure);
 295     }
 296   else
 297     {
 298       scm_gc_heap_lock = 1;
 299       answer = err_filter (scm_exitval, closure);
 300     }
 301   return answer;
 302 }
 303
 304 void
 305 scm_init_root ()
 306 {
 307   scm_tc16_root = scm_newsmob (&root_smob);
 308 #include "root.x"
 309 }