From c09346521eed9b46e0efe5a6173492ce0d675841 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 1 Sep 2008 23:54:15 -0700 Subject: Fix compilation #ifndef STACK_CHECKING. * libguile/debug.c (scm_debug_options): Fix compilation #ifndef STACK_CHECKING. --- libguile/debug.c | 2 ++ 1 file changed, 2 insertions(+) (limited to 'libguile/debug.c') diff --git a/libguile/debug.c b/libguile/debug.c index 08793f3ff..1f2acc9e6 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -69,7 +69,9 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0, SCM_OUT_OF_RANGE (1, setting); } SCM_RESET_DEBUG_MODE; +#ifdef STACK_CHECKING scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; +#endif scm_debug_eframe_size = 2 * SCM_N_FRAMES; scm_dynwind_end (); -- cgit v1.2.3 From 107139eaadab946e9713748cdeacd07b22a181db Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 26 Sep 2008 12:03:36 +0200 Subject: 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. --- ice-9/boot-9.scm | 8 ++++++++ libguile/debug.c | 23 +++++------------------ libguile/debug.h | 2 +- module/language/scheme/translate.scm | 4 ---- 4 files changed, 14 insertions(+), 23 deletions(-) (limited to 'libguile/debug.c') diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index daf8e49b8..bde0b852a 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -750,6 +750,14 @@ +;;; {The interpreter stack} +;;; + +(defmacro start-stack (tag exp) + `(%start-stack ,tag (lambda () ,exp))) + + + ;;; {Loading by paths} ;;; diff --git a/libguile/debug.c b/libguile/debug.c index 1f2acc9e6..27e9a10bc 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -445,8 +445,10 @@ scm_reverse_lookup (SCM env, SCM data) return SCM_BOOL_F; } -SCM -scm_start_stack (SCM id, SCM exp, SCM env) +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 { SCM answer; 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[0].id = id; 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); 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 - /* {Debug Objects} * * The debugging evaluator throws these on frame traps. diff --git a/libguile/debug.h b/libguile/debug.h index 607716230..4e94b3c15 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -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_local_eval (SCM exp, SCM env); 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_source (SCM proc); SCM_API SCM scm_procedure_name (SCM proc); diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm index 20164b72a..799e67c23 100644 --- a/module/language/scheme/translate.scm +++ b/module/language/scheme/translate.scm @@ -303,10 +303,6 @@ runtime))) (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 (apply (,args (retrans `(@apply ,@args)))) -- cgit v1.2.3 From e311f5fa04a45e1ddc4dea4d37911c98c692848f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 2 Feb 2009 23:00:36 +0100 Subject: tick in calls, procedure-name works on compiled procedures * module/system/vm/program.scm: * libguile/programs.h: * libguile/programs.c (scm_program_bindings, scm_program_bindings) (scm_program_properties, scm_program_name): Unfortunately, implement more procs in C, so that C can use them more easily. * libguile/debug.c (scm_procedure_name): Dispatch to scm_program_name as appropriate. * libguile/vm-i-system.c (call): Tick in a call. --- libguile/debug.c | 3 ++ libguile/programs.c | 68 ++++++++++++++++++++++++++++++++++++++++---- libguile/programs.h | 4 +++ libguile/vm-i-system.c | 3 ++ module/system/vm/program.scm | 18 ------------ 5 files changed, 72 insertions(+), 24 deletions(-) (limited to 'libguile/debug.c') diff --git a/libguile/debug.c b/libguile/debug.c index 4de7024ab..ac9a89143 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -42,6 +42,7 @@ #include "libguile/root.h" #include "libguile/fluids.h" #include "libguile/objects.h" +#include "libguile/programs.h" #include "libguile/validate.h" #include "libguile/debug.h" @@ -314,6 +315,8 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0, #endif if (scm_is_false (name) && SCM_CLOSUREP (proc)) name = scm_reverse_lookup (SCM_ENV (proc), proc); + if (scm_is_false (name) && SCM_PROGRAM_P (proc)) + name = scm_program_name (proc); return name; } } diff --git a/libguile/programs.c b/libguile/programs.c index b6dd7c2a6..9e0ff2ecf 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -48,6 +48,7 @@ #include "instructions.h" #include "modules.h" #include "programs.h" +#include "procprop.h" // scm_sym_name #include "vm.h" @@ -190,18 +191,73 @@ SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0, } #undef FUNC_NAME -extern SCM -scm_c_program_source (SCM program, size_t ip) +SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_bindings { - SCM meta, sources, source; + SCM meta; + + SCM_VALIDATE_PROGRAM (1, program); meta = scm_program_meta (program); if (scm_is_false (meta)) return SCM_BOOL_F; - meta = scm_call_0 (meta); + + return scm_car (scm_call_0 (meta)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_sources +{ + SCM meta; + + SCM_VALIDATE_PROGRAM (1, program); + + meta = scm_program_meta (program); if (scm_is_false (meta)) - return SCM_BOOL_F; - sources = scm_cadr (meta); + return SCM_EOL; + + return scm_cadr (scm_call_0 (meta)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_properties, "program-properties", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_properties +{ + SCM meta; + + SCM_VALIDATE_PROGRAM (1, program); + + meta = scm_program_meta (program); + if (scm_is_false (meta)) + return SCM_EOL; + + return scm_cddr (scm_call_0 (meta)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_name, "program-name", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_name +{ + SCM_VALIDATE_PROGRAM (1, program); + return scm_assq_ref (scm_program_properties (program), scm_sym_name); +} +#undef FUNC_NAME + +extern SCM +scm_c_program_source (SCM program, size_t ip) +{ + SCM sources, source; + + sources = scm_program_sources (program); source = scm_assv (scm_from_size_t (ip), sources); if (scm_is_false (source)) return SCM_BOOL_F; diff --git a/libguile/programs.h b/libguile/programs.h index 024ca1926..7d9478877 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -66,6 +66,10 @@ extern SCM scm_program_p (SCM obj); extern SCM scm_program_base (SCM program); extern SCM scm_program_arity (SCM program); extern SCM scm_program_meta (SCM program); +extern SCM scm_program_bindings (SCM program); +extern SCM scm_program_sources (SCM program); +extern SCM scm_program_properties (SCM program); +extern SCM scm_program_name (SCM program); extern SCM scm_program_objects (SCM program); extern SCM scm_program_module (SCM program); extern SCM scm_program_external (SCM program); diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 002b0042e..677db3ecc 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -488,6 +488,9 @@ VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1) vm_call: x = sp[-nargs]; + SYNC_REGISTER (); + SCM_TICK; /* allow interrupt here */ + /* * Subprogram call */ diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 5bf243785..cfb7362b4 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -51,13 +51,6 @@ (define (binding:start b) (list-ref b 3)) (define (binding:end b) (list-ref b 4)) -(define (curry1 proc) - (lambda (x) (proc (x)))) - -(define (program-bindings prog) - (cond ((program-meta prog) => (curry1 car)) - (else #f))) - (define (source:addr source) (car source)) (define (source:line source) @@ -67,23 +60,12 @@ (define (source:file source) (vector-ref (cdr source) 2)) -(define (program-sources prog) - (cond ((program-meta prog) => (curry1 cadr)) - (else '()))) - -(define (program-properties prog) - (or (and=> (program-meta prog) (curry1 cddr)) - '())) - (define (program-property prog prop) (assq-ref (program-properties proc) prop)) (define (program-documentation prog) (assq-ref (program-properties prog) 'documentation)) -(define (program-name prog) - (assq-ref (program-properties prog) 'name)) - (define (program-bindings-as-lambda-list prog) (let ((bindings (program-bindings prog)) (nargs (arity:nargs (program-arity prog))) -- cgit v1.2.3