[Patch] Better reflection for procedures with optional/key args

[Matthias Koeppe]

The procedure ARITY from (ice-9 session) allows to query the arity of
a procedure, including the names of the arguments if they are
available:

        guile> (arity display) ; primitive procedure
        1 required and 1 optional argument.
        guile> (arity apropos)
        1 or more arguments: `rgx', the rest in `options'.

However, if one defines procedures having optional or keyword defines,
the result is not very useful:

        guile> (use-modules (ice-9 optargs))
        guile> (define* (foo #:optional a b c) a)
        guile> (arity foo)
        0 or more arguments in `lambda*:G0'.
        
The following patch makes the behaviour of ARITY more useful by
introducing a procedure property ARGLIST, which is set by DEFINE* and
retrieved by ARITY.  No change to the handling of ordinary procedures
is made.  The result looks like this:

        guile> (arity foo)
        3 optional arguments: `a', `b' and `c'.
        guile> (define* (bar a b #:key c d #:allow-other-keys) a)
        guile> (arity bar)
        2 required arguments: `a' and `b', 2 keyword arguments: `c'
        and `d', other keywords allowed.
        guile> (define* (baz a b #:optional c #:rest r) a)
        guile> (arity baz)
        2 required arguments: `a' and `b', 1 optional argument: `c', 
        the rest in `r'.

2001-09-05  Matthias Koeppe  <address@hidden>

        * optargs.scm (lambda*): Record the broken-down argument list in
        the `arglist' procedure property.
        * session.scm (arity): Use it here to present a more detailed
        argument list.

Index: ice-9/optargs.scm
===================================================================
RCS file: /cvs/guile/guile-core/ice-9/optargs.scm,v
retrieving revision 1.14.2.1
diff -u -r1.14.2.1 optargs.scm
--- ice-9/optargs.scm   2001/07/19 20:52:33     1.14.2.1
+++ ice-9/optargs.scm   2001/09/05 14:36:58
@@ -275,27 +275,36 @@
      (if (not (or (symbol? rest-arg) (eq? #f rest-arg)))
         (error "Syntax error in rest argument declaration."))
      ;; generate the code.
-     (let ((rest-gensym (or rest-arg (gensym "lambda*:G"))))
+     (let ((rest-gensym (or rest-arg (gensym "lambda*:G")))
+          (lambda-gensym (gensym "lambda*:L")))
        (if (not (and (null? optionals) (null? keys)))
-          `(lambda (,@non-optional-args . ,rest-gensym)
-             ;; Make sure that if the proc had a docstring, we put it
-             ;; here where it will be visible.
-             ,@(if (and (not (null? BODY))
-                        (string? (car BODY)))
-                   (list (car BODY))
-                   '())
-             (let-optional*
-              ,rest-gensym
-              ,optionals
-              (let-keywords* ,rest-gensym
-                             ,aok?
-                             ,keys
-                             ,@(if (and (not rest-arg) (null? keys))
-                                   `((if (not (null? ,rest-gensym))
-                                         (error "Too many arguments.")))
-                                   '())
-                             (let ()
-                               ,@BODY))))
+          `(let ((,lambda-gensym
+                  (lambda (,@non-optional-args . ,rest-gensym)
+                    ;; Make sure that if the proc had a docstring, we put it
+                    ;; here where it will be visible.
+                    ,@(if (and (not (null? BODY))
+                               (string? (car BODY)))
+                          (list (car BODY))
+                          '())
+                    (let-optional*
+                     ,rest-gensym
+                     ,optionals
+                     (let-keywords* ,rest-gensym
+                                    ,aok?
+                                    ,keys
+                                    ,@(if (and (not rest-arg) (null? keys))
+                                          `((if (not (null? ,rest-gensym))
+                                                (error "Too many arguments.")))
+                                          '())
+                                    (let ()
+                                      ,@BODY))))))
+             (set-procedure-property! ,lambda-gensym 'arglist
+                                      '(,non-optional-args
+                                        ,optionals
+                                        ,keys
+                                        ,aok?
+                                        ,rest-arg))
+             ,lambda-gensym)
           `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '()))
              ,@BODY))))))
 
Index: ice-9/session.scm
===================================================================
RCS file: /cvs/guile/guile-core/ice-9/session.scm,v
retrieving revision 1.30
diff -u -r1.30 session.scm
--- ice-9/session.scm   2001/06/03 23:29:45     1.30
+++ ice-9/session.scm   2001/09/05 14:36:58
@@ -400,43 +400,85 @@
        (else #f)))
 
 (define-public (arity obj)
-  (let ((arity (procedure-property obj 'arity)))
-    (display (car arity))
-    (cond ((caddr arity)
-          (display " or more"))
-         ((not (zero? (cadr arity)))
-          (display " required and ")
-          (display (cadr arity))
-          (display " optional")))
-    (if (and (not (caddr arity))
-            (= (car arity) 1)
-            (<= (cadr arity) 1))
-       (display " argument")
-       (display " arguments"))
-    (if (closure? obj)
-       (let ((formals (cadr (procedure-source obj))))
-         (if (pair? formals)
-             (begin
-               (display ": `")
-               (display (car formals))
-               (let loop ((ls (cdr formals)))
-                 (cond ((null? ls)
-                        (display #\'))
-                       ((not (pair? ls))
-                        (display "', the rest in `")
-                        (display ls)
-                        (display #\'))
-                       (else
-                        (if (pair? (cdr ls))
-                            (display "', `")
-                            (display "' and `"))
-                        (display (car ls))
-                        (loop (cdr ls))))))
-             (begin
-               (display " in `")
-               (display formals)
-               (display #\')))))
-    (display ".\n")))
+  (define (display-arg-list arg-list)
+    (display #\`)
+    (display (car arg-list))
+    (let loop ((ls (cdr arg-list)))
+      (cond ((null? ls)
+            (display #\'))
+           ((not (pair? ls))
+            (display "', the rest in `")
+            (display ls)
+            (display #\'))         
+           (else
+            (if (pair? (cdr ls))
+                (display "', `")
+                (display "' and `"))
+            (display (car ls))
+            (loop (cdr ls))))))
+  (define (display-arg-list/summary arg-list type)
+    (let ((len (length arg-list)))
+      (display len)
+      (display " ")
+      (display type)
+      (if (> len 1)
+         (display " arguments: ")
+         (display " argument: "))
+      (display-arg-list arg-list)))
+  (cond
+   ((procedure-property obj 'arglist)
+    => (lambda (arglist)
+        (let ((required-args (car arglist))
+              (optional-args (cadr arglist))
+              (keyword-args (caddr arglist))
+              (allow-other-keys? (cadddr arglist))
+              (rest-arg (car (cddddr arglist)))
+              (need-punctuation #f))
+          (cond ((not (null? required-args))
+                 (display-arg-list/summary required-args "required")
+                 (set! need-punctuation #t)))
+          (cond ((not (null? optional-args))
+                 (if need-punctuation (display ", "))
+                 (display-arg-list/summary optional-args "optional")
+                 (set! need-punctuation #t)))
+          (cond ((not (null? keyword-args))
+                 (if need-punctuation (display ", "))
+                 (display-arg-list/summary keyword-args "keyword")
+                 (set! need-punctuation #t)))
+          (cond (allow-other-keys?
+                 (if need-punctuation (display ", "))
+                 (display "other keywords allowed")
+                 (set! need-punctuation #t)))
+          (cond (rest-arg
+                 (if need-punctuation (display ", "))
+                 (display "the rest in `")
+                 (display rest-arg)
+                 (display "'"))))))
+   (else
+    (let ((arity (procedure-property obj 'arity)))
+      (display (car arity))
+      (cond ((caddr arity)
+            (display " or more"))
+           ((not (zero? (cadr arity)))
+            (display " required and ")
+            (display (cadr arity))
+            (display " optional")))
+      (if (and (not (caddr arity))
+              (= (car arity) 1)
+              (<= (cadr arity) 1))
+         (display " argument")
+         (display " arguments"))
+      (if (closure? obj)
+         (let ((formals (cadr (procedure-source obj))))
+           (cond
+            ((pair? formals)
+             (display ": ")
+             (display-arg-list formals))
+            (else 
+             (display " in `")
+             (display formals)
+             (display #\'))))))))
+    (display ".\n"))
 
 (define-public system-module
   (procedure->syntax


-- 
Matthias Köppe -- http://www.math.uni-magdeburg.de/~mkoeppe
SWIG makes Guile wrappers for C/C++ libs -- http://www.swig.org
ILISP does module-aware Emacs/Guile interaction -- http://ilisp.cons.org