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.

* 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

@@ -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))
         {
@@ -80,14 +80,6 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
              see.  */
           *req -= 1;
 
-          return 1;
-        }
-      else if (SCM_RTL_PROGRAM_P (proc))
-        {
-          *req = 0;
-          *opt = 0;
-          *rest = 1;
-
           return 1;
         }
       else

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
+    write_program = scm_c_private_variable ("system vm program",
-      (scm_c_resolve_module ("system vm program"),
+                                            "write-program");
-       scm_from_latin1_symbol ("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;

module/system/vm/debug.scm

@@ -55,7 +55,8 @@
             find-debug-context
             find-program-debug-info
             arity-arguments-alist
-            find-program-arities))
+            find-program-arities
+            program-minimum-arity))
 
 ;;; A compiled procedure comes from a specific loaded ELF image.  A
 ;;; debug context identifies that image.

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 (write-program prog port)
+(define (program-arguments-alists prog)
-  (format port "#<procedure ~a~a>"
+  (cond
-          (or (procedure-name prog)
+   ((rtl-program? prog)
-              (and=> (and (program? prog) (program-source prog 0))
+    (map arity-arguments-alist
-                     (lambda (s)
+         (find-program-arities (rtl-program-code prog))))
-                       (format #f "~a at ~a:~a:~a"
+   ((program? prog)
-                               (number->string (object-address prog) 16)
+    (map (lambda (arity) (arity->arguments-alist prog arity))
-                               (or (source:file s)
+         (or (program-arities prog) '())))
-                                   (if s "<current input>" "<unknown port>"))
+   (else (error "expected a program" prog))))
-                               (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 (write-program prog port)
+  (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)))

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))))))