summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-09-12 23:14:46 +0200
committerAndy Wingo <wingo@pobox.com>2008-09-13 14:19:30 +0200
commite6fea6182305f12db177af855f5c8343b4768c14 (patch)
treec84fae74eb382ba993ed121cb45dd84770b7f236
parent5dcf8f3555d8a96cc0c028f50c12968a4e238506 (diff)
downloadguile-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.c17
-rw-r--r--module/system/vm/frame.scm8
-rw-r--r--module/system/vm/program.scm22
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)))