mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 13:00:26 +02:00
Code Activity

%start-stack in Scheme, in terms of prompts

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2010-03-07 22:37:57 +01:00
parent 5c606217a4
commit a6cd355510
5 changed files with 15 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

9
libguile/debug.c
View file

@ -208,15 +208,6 @@ scm_reverse_lookup (SCM env, SCM data)
return SCM_BOOL_F; 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
/* Undocumented debugging procedure */ /* Undocumented debugging procedure */

3
libguile/debug.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_DEBUG_H #ifndef SCM_DEBUG_H
#define 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. * Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
@ -42,7 +42,6 @@ typedef union scm_t_debug_info
SCM_API SCM scm_reverse_lookup (SCM env, SCM data); 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_source (SCM proc);
SCM_API SCM scm_procedure_name (SCM proc); SCM_API SCM scm_procedure_name (SCM proc);
SCM_API SCM scm_with_traps (SCM thunk); SCM_API SCM scm_with_traps (SCM thunk);

6
libguile/vm.c
View file

@ -544,12 +544,6 @@ SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
} }
#undef FUNC_NAME #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 */ /* Scheme interface */
SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0, SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,

1
libguile/vm.h
View file

@ -64,7 +64,6 @@ SCM_API SCM scm_the_vm ();
SCM_API SCM scm_make_vm (void); SCM_API SCM scm_make_vm (void);
SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args); 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_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_ref (SCM vm, SCM key);
SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val); SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);

16
module/ice-9/boot-9.scm
View file

@ -1022,8 +1022,20 @@ If there is no handler at all, Guile prints an error and then exits."
;;; {The interpreter stack} ;;; {The interpreter stack}
;;; ;;;
(defmacro start-stack (tag exp) (define %stacks (make-fluid))
`(%start-stack ,tag (lambda () ,exp))) (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)))))