From 8bd261baaa96eba005517eef5fb8d5d08f22720a Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Fri, 18 Oct 2013 18:41:59 +0200
Subject: [PATCH] (language tree-il analyze) works better with RTL programs

* module/system/vm/program.scm (program-arguments-alists): Export this
  interface.  Fall back to grovelling through procedure-minimum-arity if
  the program has no arities, as might be the case for continuations.

* module/language/tree-il/analyze.scm (validate-arity): Use
  program-arguments-alists instead of the program-arities interface, to
  cover both stack VM and RTL programs.
---
 module/language/tree-il/analyze.scm | 12 +++++++-----
 module/system/vm/program.scm        | 16 +++++++++++-----
 2 files changed, 18 insertions(+), 10 deletions(-)

diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 2f6e36960..22287f6d4 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -950,13 +950,15 @@ given `tree-il' element."
       (or (and (or (null? x) (pair? x))
                (length x))
           0))
-    (cond ((program? proc)
+    (cond ((or (program? proc) (rtl-program? proc))
            (values (procedure-name proc)
                    (map (lambda (a)
-                          (list (arity:nreq a) (arity:nopt a) (arity:rest? a)
-                                (map car (arity:kw a))
-                                (arity:allow-other-keys? a)))
-                        (program-arities proc))))
+                          (list (length (or (assq-ref a 'required) '()))
+                                (length (or (assq-ref a 'optional) '()))
+                                (and (assq-ref a 'rest) #t)
+                                (map car (or (assq-ref a 'keyword) '()))
+                                (assq-ref a 'allow-other-keys?)))
+                        (program-arguments-alists proc))))
           ((procedure? proc)
            (if (struct? proc)
                ;; An applicable struct.
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 4466504de..2c8cd75a7 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -41,7 +41,8 @@
 
             arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
 
-            program-arguments-alist program-lambda-list
+            program-arguments-alist program-arguments-alists
+            program-lambda-list
 
             program-meta
             program-objcode program? program-objects
@@ -340,8 +341,9 @@
             0)))
 
 (define (program-arguments-alists prog)
-  (cond
-   ((primitive? prog)
+  "Returns all arities of the given procedure, as a list of association
+lists."
+  (define (fallback)
     (match (procedure-minimum-arity prog)
       (#f '())
       ((nreq nopt rest?)
@@ -349,9 +351,13 @@
         (arity->arguments-alist
          prog
          (list 0 0 nreq nopt rest? '(#f . ())))))))
+  (cond
+   ((primitive? prog) (fallback))
    ((rtl-program? prog)
-    (map arity-arguments-alist
-         (or (find-program-arities (rtl-program-code prog)) '())))
+    (let ((arities (find-program-arities (rtl-program-code prog))))
+      (if arities
+          (map arity-arguments-alist arities)
+          (fallback))))
    ((program? prog)
     (map (lambda (arity) (arity->arguments-alist prog arity))
          (or (program-arities prog) '())))