From e311f5fa04a45e1ddc4dea4d37911c98c692848f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 2 Feb 2009 23:00:36 +0100 Subject: [PATCH] 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(-) 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)))