guile/guile-core/ice-9 session.scm

[Thien-Thi Nguyen]

CVSROOT:        /cvs
Module name:    guile
Changes by:     Thien-Thi Nguyen <address@hidden>       01/09/08 18:00:30

Modified files:
        guile-core/ice-9: session.scm 

Log message:
        (arity): Use new `arglist' procedure property to
        present a more detailed argument list.

CVSWeb URLs:
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/ice-9/session.scm.diff?cvsroot=OldCVS&tr1=1.30&tr2=1.31&r1=text&r2=text

Patches:
Index: guile/guile-core/ice-9/session.scm
diff -u guile/guile-core/ice-9/session.scm:1.30 
guile/guile-core/ice-9/session.scm:1.31
--- guile/guile-core/ice-9/session.scm:1.30     Sun Jun  3 16:29:45 2001
+++ guile/guile-core/ice-9/session.scm  Sat Sep  8 18:00:30 2001
@@ -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