mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 12:20:26 +02:00
actually compile start-stack to something useful
* ice-9/boot-9.scm (start-stack): Define as a defmacro instead of an acro in C. We have a way to delay evaluation of the exp, after all: putting it in a thunk is sufficient. * libguile/debug.h: * libguile/debug.c (scm_sys_start_stack): Renamed from scm_start_stack, and exposed to the user. Takes a thunk instead of an expression + environment. (scm_m_start_stack): Remove this acro. * module/language/scheme/translate.scm (custom-transformer-table): Remove the start-stack special case.
This commit is contained in:
parent
99b1dd09cc
commit
107139eaad
4 changed files with 14 additions and 23 deletions
|
@ -750,6 +750,14 @@
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;;; {The interpreter stack}
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(defmacro start-stack (tag exp)
|
||||||
|
`(%start-stack ,tag (lambda () ,exp)))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;; {Loading by paths}
|
;;; {Loading by paths}
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
|
|
|
@ -445,8 +445,10 @@ scm_reverse_lookup (SCM env, SCM data)
|
||||||
return SCM_BOOL_F;
|
return SCM_BOOL_F;
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM
|
SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0,
|
||||||
scm_start_stack (SCM id, SCM exp, SCM env)
|
(SCM id, SCM thunk),
|
||||||
|
"Call @var{thunk} on an evaluator stack tagged with @var{id}.")
|
||||||
|
#define FUNC_NAME s_scm_sys_start_stack
|
||||||
{
|
{
|
||||||
SCM answer;
|
SCM answer;
|
||||||
scm_t_debug_frame vframe;
|
scm_t_debug_frame vframe;
|
||||||
|
@ -456,27 +458,12 @@ scm_start_stack (SCM id, SCM exp, SCM env)
|
||||||
vframe.vect = &vframe_vect_body;
|
vframe.vect = &vframe_vect_body;
|
||||||
vframe.vect[0].id = id;
|
vframe.vect[0].id = id;
|
||||||
scm_i_set_last_debug_frame (&vframe);
|
scm_i_set_last_debug_frame (&vframe);
|
||||||
answer = scm_i_eval (exp, env);
|
answer = scm_call_0 (thunk);
|
||||||
scm_i_set_last_debug_frame (vframe.prev);
|
scm_i_set_last_debug_frame (vframe.prev);
|
||||||
return answer;
|
return answer;
|
||||||
}
|
}
|
||||||
|
|
||||||
SCM_SYNTAX(s_start_stack, "start-stack", scm_makacro, scm_m_start_stack);
|
|
||||||
|
|
||||||
static SCM
|
|
||||||
scm_m_start_stack (SCM exp, SCM env)
|
|
||||||
#define FUNC_NAME s_start_stack
|
|
||||||
{
|
|
||||||
exp = SCM_CDR (exp);
|
|
||||||
if (!scm_is_pair (exp)
|
|
||||||
|| !scm_is_pair (SCM_CDR (exp))
|
|
||||||
|| !scm_is_null (SCM_CDDR (exp)))
|
|
||||||
SCM_WRONG_NUM_ARGS ();
|
|
||||||
return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env);
|
|
||||||
}
|
|
||||||
#undef FUNC_NAME
|
#undef FUNC_NAME
|
||||||
|
|
||||||
|
|
||||||
/* {Debug Objects}
|
/* {Debug Objects}
|
||||||
*
|
*
|
||||||
* The debugging evaluator throws these on frame traps.
|
* The debugging evaluator throws these on frame traps.
|
||||||
|
|
|
@ -138,7 +138,7 @@ SCM_API scm_t_bits scm_tc16_memoized;
|
||||||
SCM_API SCM scm_debug_object_p (SCM obj);
|
SCM_API SCM scm_debug_object_p (SCM obj);
|
||||||
SCM_API SCM scm_local_eval (SCM exp, SCM env);
|
SCM_API SCM scm_local_eval (SCM exp, SCM env);
|
||||||
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
|
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
|
||||||
SCM_API SCM scm_start_stack (SCM info_id, SCM exp, SCM env);
|
SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk);
|
||||||
SCM_API SCM scm_procedure_environment (SCM proc);
|
SCM_API SCM scm_procedure_environment (SCM proc);
|
||||||
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);
|
||||||
|
|
|
@ -303,10 +303,6 @@
|
||||||
runtime)))
|
runtime)))
|
||||||
(else (syntax-error l "bad eval-case clause" (car in))))))))))))
|
(else (syntax-error l "bad eval-case clause" (car in))))))))))))
|
||||||
|
|
||||||
;; FIXME: make this actually do something
|
|
||||||
(start-stack
|
|
||||||
((,tag ,expr) (retrans expr)))
|
|
||||||
|
|
||||||
;; FIXME: not hygienic, relies on @apply not being shadowed
|
;; FIXME: not hygienic, relies on @apply not being shadowed
|
||||||
(apply
|
(apply
|
||||||
(,args (retrans `(@apply ,@args))))
|
(,args (retrans `(@apply ,@args))))
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue