[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
guile/guile-core/ice-9 session.scm
From: |
Thien-Thi Nguyen |
Subject: |
guile/guile-core/ice-9 session.scm |
Date: |
Sat, 08 Sep 2001 18:16:42 -0700 |
CVSROOT: /cvs
Module name: guile
Branch: branch_release-1-6
Changes by: Thien-Thi Nguyen <address@hidden> 01/09/08 18:16:42
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&only_with_tag=branch_release-1-6&tr1=1.30&tr2=1.30.2.1&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