diff options
author | Andy Wingo <wingo@pobox.com> | 2008-09-12 23:14:46 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2008-09-13 14:19:30 +0200 |
commit | e6fea6182305f12db177af855f5c8343b4768c14 (patch) | |
tree | c84fae74eb382ba993ed121cb45dd84770b7f236 | |
parent | 5dcf8f3555d8a96cc0c028f50c12968a4e238506 (diff) | |
download | guile-e6fea6182305f12db177af855f5c8343b4768c14.tar.gz |
programs can now get at their names, and print nicely
* module/system/vm/frame.scm (frame-call-representation)
(frame-program-name): Rename program-name to frame-program-name, and
use the program-name if it is available.
* module/system/vm/program.scm (program-bindings): Return #f if there are
no bindings.
(program-name): New public procedure.
(program-bindings-as-lambda-list, write-program): A more useful writer
for programs.
* libguile/programs.c (scm_bootstrap_programs, program_print): Add a smob
printer for programs, which dispatches to `write-program'.
-rw-r--r-- | libguile/programs.c | 17 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 8 | ||||
-rw-r--r-- | module/system/vm/program.scm | 22 |
3 files changed, 43 insertions, 4 deletions
diff --git a/libguile/programs.c b/libguile/programs.c index 1b3895ba2..71abaa750 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -54,6 +54,7 @@ scm_t_bits scm_tc16_program; static SCM zero_vector; +static SCM write_program = SCM_BOOL_F; SCM scm_c_make_program (void *addr, size_t size, SCM holder) @@ -125,6 +126,21 @@ program_apply (SCM program, SCM args) return scm_vm_apply (scm_the_vm (), program, args); } +static int +program_print (SCM program, SCM port, scm_print_state *pstate) +{ + if (SCM_FALSEP (write_program)) + write_program = scm_module_local_variable + (scm_c_resolve_module ("system vm program"), + scm_from_locale_symbol ("write-program")); + + if (SCM_FALSEP (write_program)) + return scm_smob_print (program, port, pstate); + + scm_call_2 (SCM_VARIABLE_REF (write_program), program, port); + return 1; +} + /* * Scheme interface @@ -252,6 +268,7 @@ scm_bootstrap_programs (void) scm_set_smob_mark (scm_tc16_program, program_mark); scm_set_smob_free (scm_tc16_program, program_free); scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1); + scm_set_smob_print (scm_tc16_program, program_print); } void diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index a3e115d35..6bcbb5ffd 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -104,7 +104,7 @@ ((1) (vector (abbrev (vector-ref x 0)))) (else (vector (abbrev (vector-ref x 0)) '...)))) (else x))) - (abbrev (cons (program-name frame) (frame-arguments frame)))) + (abbrev (cons (frame-program-name frame) (frame-arguments frame)))) (define (print-frame-chain-as-backtrace frames) (if (null? frames) @@ -120,10 +120,11 @@ 'no-file frames)))) -(define (program-name frame) +(define (frame-program-name frame) (let ((prog (frame-program frame)) (link (frame-dynamic-link frame))) - (or (object-property prog 'name) + (or (program-name prog) + (object-property prog 'name) (and (heap-frame? link) (frame-address link) (frame-object-name link (1- (frame-address link)) prog)) (hash-fold (lambda (s v d) (if (eq? prog (variable-ref v)) s d)) @@ -167,6 +168,7 @@ (frame-external-set! frame (binding:index binding) val) (frame-local-set! frame (binding:index binding) val))) +;; FIXME handle #f program-bindings return (define (frame-bindings frame addr) (do ((bs (program-bindings (frame-program frame)) (cdr bs)) (ls '() (if (cdar bs) (cons (cdar bs) ls) (cdr ls)))) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 25f403c2a..4be2da10e 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -25,6 +25,7 @@ source:addr source:line source:column source:file program-bindings program-sources program-properties program-property program-documentation + program-name program-arity program-external-set! program-meta program-bytecode program? program-objects @@ -49,7 +50,7 @@ (define (program-bindings prog) (cond ((program-meta prog) => (curry1 car)) - (else '()))) + (else #f))) (define (source:addr source) (car source)) @@ -74,3 +75,22 @@ (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))) + (rest? (not (zero? (arity:nrest (program-arity prog)))))) + (if (not bindings) + (if rest? (cons (1- nargs) 1) (list nargs)) + (let ((arg-names (map binding:name (cdar bindings)))) + (if rest? + (apply cons* arg-names) + arg-names))))) + +(define (write-program prog port) + (format port "#<program ~a ~a>" + (or (program-name prog) + (number->string (object-address prog) 16)) + (program-bindings-as-lambda-list prog))) |