*** empty log message ***
[bpt/guile.git] / libguile / root.c
CommitLineData
4ea1f83d 1/* Copyright (C) 1995,1996,1997,1998, 1999 Free Software Foundation, Inc.
0f2d19dd
JB
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
82892bed
JB
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
0f2d19dd
JB
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.
82892bed 40 * If you do not wish that, delete this exception notice. */
1bbd0b84
GB
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
0f2d19dd
JB
45\f
46
47#include <stdio.h>
48#include "_scm.h"
20e6290e 49#include "stackchk.h"
d564d753
MD
50#include "dynwind.h"
51#include "eval.h"
d564d753
MD
52#include "smob.h"
53#include "pairs.h"
54#include "throw.h"
d9dfcf80 55#include "fluids.h"
f04d8caf 56#include "ports.h"
0f2d19dd 57
20e6290e 58#include "root.h"
0f2d19dd
JB
59\f
60
e71575d9
MV
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
0f2d19dd 67SCM scm_sys_protects[SCM_NUM_PROTECTS];
d564d753
MD
68
69long scm_tc16_root;
70
71#ifndef USE_THREADS
72struct scm_root_state *scm_root;
73#endif
0f2d19dd
JB
74
75\f
76
d564d753 77static SCM
1bbd0b84 78mark_root (SCM root)
d564d753
MD
79{
80 scm_root_state *s = SCM_ROOT_STATE (root);
dc53f026 81
d564d753
MD
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);
903073d5 94 /* No need to gc mark def_loadp */
d9dfcf80 95 scm_gc_mark (s->fluids);
dc19d1d2 96 scm_gc_mark (s->top_level_lookup_closure_var);
d564d753
MD
97 scm_gc_mark (s->system_transformer);
98 return SCM_ROOT_STATE (root) -> parent;
99}
0f2d19dd 100
d564d753 101
d564d753 102static int
1bbd0b84 103print_root (SCM exp,SCM port,scm_print_state *pstate)
d564d753 104{
b7f3516f 105 scm_puts ("#<root ", port);
d564d753 106 scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
b7f3516f 107 scm_putc('>', port);
d564d753
MD
108 return 1;
109}
110
d564d753
MD
111
112\f
113
114SCM
1bbd0b84 115scm_make_root (SCM parent)
d564d753
MD
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");
0c95b57d 122 if (SCM_ROOTP (parent))
d564d753
MD
123 {
124 memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state));
d9dfcf80 125 scm_copy_fluids (root_state);
d564d753
MD
126 root_state->parent = parent;
127 }
128 else
129 {
130 root_state->parent = SCM_BOOL_F;
4ea1f83d
JB
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;
d564d753 152 }
d564d753 153 SCM_REDEFER_INTS;
23a62151 154 SCM_NEWSMOB (root, scm_tc16_root, root_state);
d564d753
MD
155 root_state->handle = root;
156 SCM_REALLOW_INTS;
157 return root;
158}
159
1cc91f1b 160/* {call-with-dynamic-root}
d564d753
MD
161 *
162 * Suspending the current thread to evaluate a thunk on the
163 * same C stack but under a new root.
164 *
1cc91f1b 165 * Calls to call-with-dynamic-root return exactly once (unless
e71575d9 166 * the process is somehow exitted). */
d564d753 167
650fa1ab
JB
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
d564d753
MD
181#if 0
182SCM scm_exitval; /* INUM with return value */
183#endif
184static int n_dynamic_roots = 0;
185
650fa1ab 186
e71575d9
MV
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.
650fa1ab
JB
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
e71575d9
MV
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. */
650fa1ab
JB
197
198struct cwdr_body_data {
650fa1ab
JB
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;
e71575d9
MV
204};
205
206struct cwdr_handler_data {
207 /* Do we need to run the handler? */
208 int run_handler;
f032b8a8 209
e71575d9
MV
210 /* The tag and args to pass it. */
211 SCM tag, args;
650fa1ab
JB
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
816a6f06
JB
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. */
650fa1ab 221static SCM
39752bec 222cwdr_body (void *data)
650fa1ab
JB
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
e71575d9
MV
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. */
650fa1ab 232
f032b8a8 233static SCM
e71575d9 234cwdr_handler (void *data, SCM tag, SCM args)
f032b8a8 235{
e71575d9 236 struct cwdr_handler_data *c = (struct cwdr_handler_data *) data;
f032b8a8 237
e71575d9
MV
238 c->run_handler = 1;
239 c->tag = tag;
240 c->args = args;
241 return SCM_UNSPECIFIED;
f032b8a8 242}
d564d753
MD
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
650fa1ab 248 * in a messed up state. */
d564d753 249
e71575d9
MV
250SCM
251scm_internal_cwdr (scm_catch_body_t body, void *body_data,
252 scm_catch_handler_t handler, void *handler_data,
253 SCM_STACKITEM *stack_start)
d564d753 254{
e71575d9 255#ifdef USE_STACKJMPBUF
8b3bda20 256 scm_contregs static_contregs;
e71575d9 257#endif
d564d753 258 int old_ints_disabled = scm_ints_disabled;
8938d022 259 SCM old_rootcont, old_winds;
e71575d9 260 struct cwdr_handler_data my_handler_data;
d564d753
MD
261 SCM answer;
262
e71575d9 263 /* Create a fresh root continuation. */
d564d753
MD
264 {
265 SCM new_rootcont;
266 SCM_NEWCELL (new_rootcont);
267 SCM_REDEFER_INTS;
e71575d9 268#ifdef USE_STACKJMPBUF
8b3bda20 269 SCM_SET_CONTREGS (new_rootcont, &static_contregs);
e71575d9 270#else
8b3bda20
DH
271 SCM_SET_CONTREGS (new_rootcont,
272 scm_must_malloc (sizeof (scm_contregs),
273 "inferior root continuation"));
e71575d9 274#endif
54778cd3 275 SCM_SET_CELL_TYPE (new_rootcont, scm_tc7_contin);
d564d753
MD
276 SCM_DYNENV (new_rootcont) = SCM_EOL;
277 SCM_BASE (new_rootcont) = stack_start;
8938d022 278 SCM_SEQ (new_rootcont) = ++n_dynamic_roots;
d564d753
MD
279#ifdef DEBUG_EXTENSIONS
280 SCM_DFRAME (new_rootcont) = 0;
281#endif
8938d022
MD
282 old_rootcont = scm_rootcont;
283 scm_rootcont = new_rootcont;
d564d753
MD
284 SCM_REALLOW_INTS;
285 }
286
8938d022
MD
287 /* Exit caller's dynamic state.
288 */
289 old_winds = scm_dynwinds;
290 scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
d564d753 291#ifdef DEBUG_EXTENSIONS
308277cb 292 SCM_DFRAME (old_rootcont) = scm_last_debug_frame;
8938d022 293 scm_last_debug_frame = 0;
d564d753 294#endif
650fa1ab 295
e71575d9
MV
296 {
297 my_handler_data.run_handler = 0;
816a6f06 298 answer = scm_internal_catch (SCM_BOOL_T,
e71575d9
MV
299 body, body_data,
300 cwdr_handler, &my_handler_data);
650fa1ab 301 }
e71575d9 302
d564d753
MD
303 scm_dowinds (old_winds, - scm_ilength (old_winds));
304 SCM_REDEFER_INTS;
e71575d9 305#ifdef USE_STACKCJMPBUF
8b3bda20 306 SCM_SET_CONTREGS (scm_rootcont, NULL);
e71575d9 307#endif
d564d753 308#ifdef DEBUG_EXTENSIONS
308277cb 309 scm_last_debug_frame = SCM_DFRAME (old_rootcont);
d564d753 310#endif
308277cb 311 scm_rootcont = old_rootcont;
d564d753
MD
312 SCM_REALLOW_INTS;
313 scm_ints_disabled = old_ints_disabled;
e71575d9
MV
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;
d564d753
MD
320}
321
e71575d9
MV
322/* The original CWDR for invoking Scheme code with a Scheme handler. */
323
324static SCM
325cwdr (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}
d564d753 337
3b3b36dd 338SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0,
1bbd0b84 339 (SCM thunk, SCM handler),
b380b885
MD
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.)")
1bbd0b84 376#define FUNC_NAME s_scm_call_with_dynamic_root
d564d753
MD
377{
378 SCM_STACKITEM stack_place;
8938d022 379 return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
d564d753 380}
1bbd0b84 381#undef FUNC_NAME
d564d753 382
3b3b36dd 383SCM_DEFINE (scm_dynamic_root, "dynamic-root", 0, 0, 0,
1bbd0b84 384 (),
b380b885
MD
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.")
1bbd0b84 389#define FUNC_NAME s_scm_dynamic_root
d564d753
MD
390{
391 return scm_ulong2num (SCM_SEQ (scm_root->rootcont));
392}
1bbd0b84 393#undef FUNC_NAME
d564d753 394
d564d753 395SCM
1bbd0b84 396scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler)
d564d753
MD
397{
398 SCM_STACKITEM stack_place;
8938d022 399 return cwdr (proc, a1, args, handler, &stack_place);
d564d753 400}
0f2d19dd
JB
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
411typedef int setjmp_type;
412#else
413typedef long setjmp_type;
414#endif
415
416
1cc91f1b 417
0f2d19dd 418SCM
1bbd0b84 419scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void *closure)
0f2d19dd
JB
420{
421 SCM answer;
422 setjmp_type i;
faa6b3df 423#ifdef DEBUG_EXTENSIONS
8938d022 424 SCM_DFRAME (scm_rootcont) = scm_last_debug_frame;
faa6b3df 425#endif
0f2d19dd 426 i = setjmp (SCM_JMPBUF (scm_rootcont));
faa6b3df 427 scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
0f2d19dd
JB
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
d564d753
MD
441void
442scm_init_root ()
443{
23a62151
MD
444 scm_tc16_root = scm_make_smob_type_mfpe ("root", sizeof (struct scm_root_state),
445 mark_root, NULL, print_root, NULL);
446
d564d753
MD
447#include "root.x"
448}
89e00824
ML
449
450/*
451 Local Variables:
452 c-file-style: "gnu"
453 End:
454*/