Wire up ability to print RTL program arities

* libguile/procprop.c (scm_i_procedure_arity): Allow RTL programs to
  dispatch to scm_i_program_arity.

* libguile/programs.c (scm_i_program_print): Refactor reference to
  write-program.
  (scm_i_rtl_program_minimum_arity): New procedure, dispatches to
  Scheme.
  (scm_i_program_arity): Dispatch to scm_i_rtl_program_minimum_arity if
  appropriate.

* module/system/vm/debug.scm (program-minimum-arity): New export.

* module/system/vm/program.scm (rtl-program-minimum-arity): New internal
  function.
  (program-arguments-alists): New helper, implemented also for RTL
  procedures.
  (write-program): Refactor a bit, and call program-arguments-alists.

4 files changed, 82 insertions, 33 deletions

diff --git a/libguile/procprop.c b/libguile/procprop.c
index 480970266..62476c037 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -60,7 +60,7 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
       return 1;
     }
 
-  while (!SCM_PROGRAM_P (proc))
+  while (!SCM_PROGRAM_P (proc) && !SCM_RTL_PROGRAM_P (proc))
     {
       if (SCM_STRUCTP (proc))
         {
@@ -82,14 +82,6 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
 
           return 1;
         }
-      else if (SCM_RTL_PROGRAM_P (proc))
-        {
-          *req = 0;
-          *opt = 0;
-          *rest = 1;
-
-          return 1;
-        }
       else
         return 0;
     }
diff --git a/libguile/programs.c b/libguile/programs.c
index d3569159a..12561b30d 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -129,9 +129,8 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
   static int print_error = 0;
 
   if (scm_is_false (write_program) && scm_module_system_booted_p)
-    write_program = scm_module_local_variable
-      (scm_c_resolve_module ("system vm program"),
-       scm_from_latin1_symbol ("write-program"));
+    write_program = scm_c_private_variable ("system vm program",
+                                            "write-program");
   
   if (SCM_PROGRAM_IS_CONTINUATION (program))
     {
@@ -450,11 +449,36 @@ parse_arity (SCM arity, int *req, int *opt, int *rest)
     *req = *opt = *rest = 0;
 }
   
+static int
+scm_i_rtl_program_minimum_arity (SCM program, int *req, int *opt, int *rest)
+{
+  static SCM rtl_program_minimum_arity = SCM_BOOL_F;
+  SCM l;
+
+  if (scm_is_false (rtl_program_minimum_arity) && scm_module_system_booted_p)
+    rtl_program_minimum_arity =
+        scm_c_private_variable ("system vm debug",
+                                "rtl-program-minimum-arity");
+
+  l = scm_call_1 (scm_variable_ref (rtl_program_minimum_arity), program);
+  if (scm_is_false (l))
+    return 0;
+
+  *req = scm_to_int (scm_car (l));
+  *opt = scm_to_int (scm_cadr (l));
+  *rest = scm_is_true (scm_caddr (l));
+
+  return 1;
+}
+
 int
 scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
 {
   SCM arities;
   
+  if (SCM_RTL_PROGRAM_P (program))
+    return scm_i_rtl_program_minimum_arity (program, req, opt, rest);
+
   arities = scm_program_arities (program);
   if (!scm_is_pair (arities))
     return 0;
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 43527f3af..c625fb71c 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -50,7 +50,8 @@
             arity-has-keyword-args?
             arity-is-case-lambda?
             arity-arguments-alist
-            find-program-arities))
+            find-program-arities
+            program-minimum-arity))
 
 (define-record-type <debug-context>
   (make-debug-context elf base text-base)
@@ -278,3 +279,16 @@
             (first (find-first-arity context base addr)))
        ;; FIXME: Handle case-lambda arities.
        (if first (list first) '())))))
+
+(define* (program-minimum-arity addr #:optional
+                                (context (find-debug-context addr)))
+  (and=>
+   (elf-section-by-name (debug-context-elf context) ".guile.arities")
+   (lambda (sec)
+     (let* ((base (elf-section-offset sec))
+            (first (find-first-arity context base addr)))
+       (if (arity-is-case-lambda?)
+           (list 0 0 #t) ;; FIXME: be more precise.
+           (list (arity-nreq arity)
+                 (arity-nopt arity)
+                 (arity-has-rest? arity)))))))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index fdfc9a8aa..a4bd64e28 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -61,6 +61,12 @@
   (and=> (find-program-debug-info (rtl-program-code program))
          program-debug-info-name))
 
+;; This procedure is called by programs.c.
+(define (rtl-program-minimum-arity program)
+  (unless (rtl-program? program)
+    (error "shouldn't get here"))
+  (program-minimum-arity (rtl-program-code program)))
+
 (define (make-binding name boxed? index start end)
   (list name boxed? index start end))
 (define (binding:name b) (list-ref b 0))
@@ -276,25 +282,38 @@
             1+
             0)))
 
+(define (program-arguments-alists prog)
+  (cond
+   ((rtl-program? prog)
+    (map arity-arguments-alist
+         (find-program-arities (rtl-program-code prog))))
+   ((program? prog)
+    (map (lambda (arity) (arity->arguments-alist prog arity))
+         (or (program-arities prog) '())))
+   (else (error "expected a program" prog))))
+
 (define (write-program prog port)
-  (format port "#<procedure ~a~a>"
-          (or (procedure-name prog)
-              (and=> (and (program? prog) (program-source prog 0))
-                     (lambda (s)
-                       (format #f "~a at ~a:~a:~a"
-                               (number->string (object-address prog) 16)
-                               (or (source:file s)
-                                   (if s "<current input>" "<unknown port>"))
-                               (source:line-for-user s) (source:column s))))
-              (number->string (object-address prog) 16))
-          (let ((arities (and (program? prog) (program-arities prog))))
-            (if (or (not arities) (null? arities))
-                ""
-                (string-append
-                 " " (string-join (map (lambda (a)
-                                         (object->string
-                                          (arguments-alist->lambda-list
-                                           (arity->arguments-alist prog a))))
-                                       arities)
-                                  " | "))))))
+  (define (program-identity-string)
+    (or (procedure-name prog)
+        (and=> (and (program? prog) (program-source prog 0))
+               (lambda (s)
+                 (format #f "~a at ~a:~a:~a"
+                         (number->string (object-address prog) 16)
+                         (or (source:file s)
+                             (if s "<current input>" "<unknown port>"))
+                         (source:line-for-user s) (source:column s))))
+        (number->string (object-address prog) 16)))
 
+  (define (program-formals-string)
+    (let ((arguments (program-arguments-alists prog)))
+      (if (null? arguments)
+          ""
+          (string-append
+           " " (string-join (map (lambda (a)
+                                   (object->string
+                                    (arguments-alist->lambda-list a)))
+                                 arguments)
+                            " | ")))))
+
+  (format port "#<procedure ~a~a>"
+          (program-identity-string) (program-formals-string)))