From: Andy Wingo <wingo@pobox.com>
Date: Fri, 6 Jul 2012 10:19:12 +0000 (+0200)
Subject: better procedure-arguments for interpreted procs with opt, rest, kwargs
X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/fc835b1b14a38f61150557ab531de51f98239739

better procedure-arguments for interpreted procs with opt, rest, kwargs

* module/ice-9/session.scm (procedure-arguments): Arrange to interpret
  numbers in the "req" and "opt" positions of an 'arglist as N arguments
  with unknown name.

* module/ice-9/eval.scm (primitive-eval): Set 'arglist on "complex"
  procedures.  Fixes http://bugs.gnu.org/10922.

* test-suite/tests/session.test ("procedure-arguments"): Add a test.
---

diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 74b85329d..81b9538f9 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -238,7 +238,14 @@
       (define (set-procedure-arity! proc)
         (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
           (if (not alt)
-              (set-procedure-minimum-arity! proc nreq nopt rest?)
+              (begin
+                (set-procedure-property! proc 'arglist
+                                         (list nreq
+                                               nopt
+                                               (if kw (cdr kw) '())
+                                               (and kw (car kw))
+                                               (and rest? '_)))
+                (set-procedure-minimum-arity! proc nreq nopt rest?))
               (let* ((nreq* (cadr alt))
                      (rest?* (if (null? (cddr alt)) #f (caddr alt)))
                      (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt)))
diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index 0eeed86c3..ce1bcac7c 100644
--- a/module/ice-9/session.scm
+++ b/module/ice-9/session.scm
@@ -511,8 +511,12 @@ The alist keys that are currently defined are `required', `optional',
    ((procedure-property proc 'arglist)
     => (match-lambda
         ((req opt keyword aok? rest)
-         `((required . ,req)
-           (optional . ,opt)
+         `((required . ,(if (number? req)
+                            (make-list req '_)
+                            req))
+           (optional . ,(if (number? opt)
+                            (make-list opt '_)
+                            opt))
            (keyword . ,keyword)
            (allow-other-keys? . ,aok?)
            (rest . ,rest)))))
diff --git a/test-suite/tests/session.test b/test-suite/tests/session.test
index 242ecf9c1..ec992f1c8 100644
--- a/test-suite/tests/session.test
+++ b/test-suite/tests/session.test
@@ -20,6 +20,7 @@
 
 (define-module (test-suite session)
   #:use-module (test-suite lib)
+  #:use-module (ice-9 match)
   #:use-module (system base compile)
   #:use-module (ice-9 session))
 
@@ -94,7 +95,29 @@
     (let* ((proc (compile '(lambda (a b) #f) #:to 'value))
            (args (procedure-arguments proc)))
       (set-procedure-property! proc 'arglist (map cdr args))
-      (equal? args (procedure-arguments proc)))))
+      (equal? args (procedure-arguments proc))))
+
+  (pass-if "interpreted procedures (simple)"
+    (match (procedure-arguments
+            (eval '(lambda (x y) #f) (current-module)))
+      (((required _ _)
+        (optional)
+        (keyword)
+        (allow-other-keys? . #f)
+        (rest . #f))
+       #t)
+      (_ #f)))
+
+  (pass-if "interpreted procedures (complex)"
+    (match (procedure-arguments
+            (eval '(lambda* (a b #:optional c #:key d) #f) (current-module)))
+      (((required _ _)
+        (optional _)
+        (keyword (#:d . 3))
+        (allow-other-keys? . #f)
+        (rest . #f))
+       #t)
+      (_ #f))))
 
 ;;; Local Variables:
 ;;; eval: (put 'pass-if-valid-arguments 'scheme-indent-function 1)