[PATCH 6/9] Wire up ability to print RTL program arities

[Andy Wingo <wingo@pobox.com>]

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

* test-suite/tests/rtl.test ("simply procedure arity"): Add tests that
  arities make it all the way to cold ELF and back to warm Guile.
---
 libguile/procprop.c          |   10 +------
 libguile/programs.c          |   30 ++++++++++++++++++---
 module/system/vm/debug.scm   |    3 ++-
 module/system/vm/program.scm |   59 ++++++++++++++++++++++++++++--------------
 test-suite/tests/rtl.test    |   30 +++++++++++++++++++++
 5 files changed, 99 insertions(+), 33 deletions(-)

diff --git a/libguile/procprop.c b/libguile/procprop.c
index 4809702..62476c0 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 d356915..12561b3 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 724f2b4..81e2250 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -49,7 +49,8 @@
             find-debug-context
             find-program-debug-info
             arity-arguments-alist
-            find-program-arities))
+            find-program-arities
+            program-minimum-arity))
 
 (define-record-type <debug-context>
   (make-debug-context elf base text-base)
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index fdfc9a8..a4bd64e 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)))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 1813969..c50aae9 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -316,3 +316,33 @@
           (return 0)
           (end-arity)
           (end-program))))))
+
+(with-test-prefix "simply procedure arity"
+  (pass-if-equal "#<procedure foo ()>"
+      (object->string
+       (assemble-program
+        '((begin-program foo ((name . foo)))
+          (begin-standard-arity () 1 #f)
+          (load-constant 0 42)
+          (return 0)
+          (end-arity)
+          (end-program)))))
+  (pass-if-equal "#<procedure foo (x y)>"
+      (object->string
+       (assemble-program
+        '((begin-program foo ((name . foo)))
+          (begin-standard-arity (x y) 2 #f)
+          (load-constant 0 42)
+          (return 0)
+          (end-arity)
+          (end-program)))))
+
+  (pass-if-equal "#<procedure foo (x #:optional y . z)>"
+      (object->string
+       (assemble-program
+        '((begin-program foo ((name . foo)))
+          (begin-opt-arity (x) (y) z 3 #f)
+          (load-constant 0 42)
+          (return 0)
+          (end-arity)
+          (end-program))))))
-- 
1.7.10.4