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'.

diff --git a/libguile/programs.c b/libguile/programs.c
index 1b3895b..71abaa7 100644 (file)
--- 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;
+}
+
 \f
 /*
  * 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 a3e115d..6bcbb5f 100644 (file)
--- 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 25f403c..4be2da1 100644 (file)
--- 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)))