X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/5f144b105db0dcbe3b33947317d3e9b98cbd5269..9bc6fb0a7d91ae9a6c57cedb76022043db413ba5:/libguile/root.c

diff --git a/libguile/root.c b/libguile/root.c
index c0c8ebfa6..389c2247b 100644
--- a/libguile/root.c
+++ b/libguile/root.c
@@ -1,4 +1,4 @@
-/*	Copyright (C) 1995,1996,1997,1998, 1999, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001 Free Software Foundation, Inc.
  * 
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -39,12 +39,10 @@
  * whether to permit this exception to apply to your modifications.
  * If you do not wish that, delete this exception notice.  */
 
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
-   gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
 
 
 
-#include <stdio.h>
+#include <string.h>
 #include "libguile/_scm.h"
 #include "libguile/stackchk.h"
 #include "libguile/dynwind.h"
@@ -60,7 +58,7 @@
 
 SCM scm_sys_protects[SCM_NUM_PROTECTS];
 
-long scm_tc16_root;
+scm_t_bits scm_tc16_root;
 
 #ifndef USE_THREADS
 struct scm_root_state *scm_root;
@@ -69,14 +67,12 @@ struct scm_root_state *scm_root;
 
 
 static SCM
-mark_root (SCM root)
+root_mark (SCM root)
 {
   scm_root_state *s = SCM_ROOT_STATE (root);
 
   scm_gc_mark (s->rootcont);
   scm_gc_mark (s->dynwinds);
-  scm_gc_mark (s->continuation_stack);
-  scm_gc_mark (s->continuation_stack_ptr);
   scm_gc_mark (s->progargs);
   scm_gc_mark (s->exitval);
   scm_gc_mark (s->cur_inp);
@@ -92,7 +88,7 @@ mark_root (SCM root)
 
 
 static int
-print_root (SCM exp,SCM port,scm_print_state *pstate)
+root_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 {
   scm_puts ("#<root ", port);
   scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
@@ -109,8 +105,8 @@ scm_make_root (SCM parent)
   SCM root;
   scm_root_state *root_state;
 
-  root_state = (scm_root_state *) scm_must_malloc (sizeof (scm_root_state),
-						   "scm_make_root");
+  root_state = (scm_root_state *) scm_gc_malloc (sizeof (scm_root_state),
+						 "root state");
   if (SCM_ROOTP (parent))
     {
       memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state));
@@ -124,8 +120,6 @@ scm_make_root (SCM parent)
       /* Initialize everything right now, in case a GC happens early.  */
       root_state->rootcont
 	= root_state->dynwinds
-	= root_state->continuation_stack
-	= root_state->continuation_stack_ptr
 	= root_state->progargs
 	= root_state->exitval
 	= root_state->cur_inp
@@ -171,7 +165,7 @@ scm_make_root (SCM parent)
 #if 0
 SCM scm_exitval;		/* INUM with return value */
 #endif
-static int n_dynamic_roots = 0;
+static long n_dynamic_roots = 0;
 
 
 /* cwdr fills out both of these structures, and then passes a pointer
@@ -238,8 +232,8 @@ cwdr_handler (void *data, SCM tag, SCM args)
  * in a messed up state.  */
 
 SCM 
-scm_internal_cwdr (scm_catch_body_t body, void *body_data,
-		   scm_catch_handler_t handler, void *handler_data,
+scm_internal_cwdr (scm_t_catch_body body, void *body_data,
+		   scm_t_catch_handler handler, void *handler_data,
 		   SCM_STACKITEM *stack_start)
 {
   int old_ints_disabled = scm_ints_disabled;
@@ -253,8 +247,8 @@ scm_internal_cwdr (scm_catch_body_t body, void *body_data,
 
     SCM_REDEFER_INTS;
     {
-      scm_contregs *contregs = scm_must_malloc (sizeof (scm_contregs),
-						"inferior root continuation");
+      scm_t_contregs *contregs = scm_gc_malloc (sizeof (scm_t_contregs),
+						"continuation");
 
       contregs->num_stack_items = 0;
       contregs->dynenv = SCM_EOL;
@@ -334,7 +328,7 @@ SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0,
 	    "Before calling @var{thunk}, the dynamic-wind chain is un-wound back to\n"
 	    "the root and a new chain started for @var{thunk}.  Therefore, this call\n"
 	    "may not do what you expect:\n\n"
-	    "@example\n"
+	    "@lisp\n"
 	    ";; Almost certainly a bug:\n"
 	    "(with-output-to-port\n"
 	    " some-port\n\n"
@@ -344,7 +338,7 @@ SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0,
 	    "      (display 'fnord)\n"
 	    "      (newline))\n"
 	    "    (lambda (errcode) errcode))))\n"
-	    "@end example\n\n"
+	    "@end lisp\n\n"
 	    "The problem is, on what port will @samp{fnord} be displayed?  You\n"
 	    "might expect that because of the @code{with-output-to-port} that\n"
 	    "it will be displayed on the port bound to @code{some-port}.  But it\n"
@@ -384,52 +378,12 @@ scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler)
 
 
 
-#if (SCM_DEBUG_DEPRECATED == 0)
-
-/* Call thunk(closure) underneath a top-level error handler.
- * If an error occurs, pass the exitval through err_filter and return it.
- * If no error occurs, return the value of thunk.
- */
-
-#ifdef _UNICOS
-typedef int setjmp_type;
-#else
-typedef long setjmp_type;
-#endif
-
-
-SCM
-scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void *closure)
-{
-  SCM answer;
-  setjmp_type i;
-#ifdef DEBUG_EXTENSIONS
-  SCM_DFRAME (scm_rootcont) = scm_last_debug_frame;
-#endif
-  i = setjmp (SCM_JMPBUF (scm_rootcont));
-  scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
-  if (!i)
-    {
-      scm_gc_heap_lock = 0;
-      answer = thunk (closure);
-    }
-  else
-    {
-      scm_gc_heap_lock = 1;
-      answer = err_filter (scm_exitval, closure);
-    }
-  return answer;
-}
-
-#endif  /* SCM_DEBUG_DEPRECATED == 0 */
-
-
 void
 scm_init_root ()
 {
   scm_tc16_root = scm_make_smob_type ("root", sizeof (struct scm_root_state));
-  scm_set_smob_mark (scm_tc16_root, mark_root);
-  scm_set_smob_print (scm_tc16_root, print_root);
+  scm_set_smob_mark (scm_tc16_root, root_mark);
+  scm_set_smob_print (scm_tc16_root, root_print);
 
 #ifndef SCM_MAGIC_SNARFER
 #include "libguile/root.x"