%start-stack in Scheme, in terms of prompts

* libguile/debug.h:
* libguile/debug.c (scm_sys_start_stack): Removed, we implement this in
  Scheme now.

* libguile/vm.h:
* libguile/vm.c (scm_vm_call_with_new_stack): Likewise removed.

* module/ice-9/boot-9.scm (%start-stack): Implement in terms of prompts.
  (%stacks): New fluid, for tracking active stacks.
  (start-stack): Implement using syntax-rules.

diff --git a/libguile/debug.c b/libguile/debug.c
index 1c86c76..c8e908f 100644 (file)
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -208,15 +208,6 @@ scm_reverse_lookup (SCM env, SCM data)
   return SCM_BOOL_F;
 }
 
-SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0,
-            (SCM id, SCM thunk),
-           "Call @var{thunk} on an evaluator stack tagged with @var{id}.")
-#define FUNC_NAME s_scm_sys_start_stack
-{
-  return scm_vm_call_with_new_stack (scm_the_vm (), thunk, id);
-}
-#undef FUNC_NAME
-
 \f
 
 /* Undocumented debugging procedure */

diff --git a/libguile/debug.h b/libguile/debug.h
index 6a1ee5a..7c1d02f 100644 (file)
--- a/libguile/debug.h
+++ b/libguile/debug.h
@@ -3,7 +3,7 @@
 #ifndef SCM_DEBUG_H
 #define SCM_DEBUG_H
 
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -42,7 +42,6 @@ typedef union scm_t_debug_info
 \f
 
 SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
-SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk);
 SCM_API SCM scm_procedure_source (SCM proc);
 SCM_API SCM scm_procedure_name (SCM proc);
 SCM_API SCM scm_with_traps (SCM thunk);

diff --git a/libguile/vm.c b/libguile/vm.c
index 1420611..98df057 100644 (file)
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -544,12 +544,6 @@ SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM
-scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id)
-{
-  return scm_c_vm_run (vm, thunk, NULL, 0);
-}
-
 /* Scheme interface */
 
 SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,

diff --git a/libguile/vm.h b/libguile/vm.h
index ade4bb6..8e22d02 100644 (file)
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -64,7 +64,6 @@ SCM_API SCM scm_the_vm ();
 SCM_API SCM scm_make_vm (void);
 SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args);
 SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
-SCM_API SCM scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id);
 SCM_API SCM scm_vm_option_ref (SCM vm, SCM key);
 SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
 

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 0b4f83c..f023426 100644 (file)
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1022,8 +1022,20 @@ If there is no handler at all, Guile prints an error and then exits."
 ;;; {The interpreter stack}
 ;;;
 
-(defmacro start-stack (tag exp)
-  `(%start-stack ,tag (lambda () ,exp)))
+(define %stacks (make-fluid))
+(define (%start-stack tag thunk)
+  (let ((prompt-tag (gensym)))
+    (prompt prompt-tag
+            (lambda ()
+              (with-fluids ((%stacks (acons tag prompt-tag
+                                            (or (fluid-ref %stacks) '()))))
+                (thunk)))
+            (lambda (k . args)
+              (%start-stack tag (lambda () (apply k args)))))))
+(define-syntax start-stack
+  (syntax-rules ()
+    ((_ tag exp)
+     (%start-stack tag (lambda () exp)))))
 
 \f