mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-08 05:00:17 +02:00
Code Activity

(arity): Use new `arglist' procedure property to

Browse source 
present a more detailed argument list.
This commit is contained in:
Thien-Thi Nguyen 2001-09-09 01:00:30 +00:00
parent 4a69c751ef
commit c7bb434f2f
1 changed files with 79 additions and 37 deletions
Download patch file Download diff file Expand all files Collapse all files

116
ice-9/session.scm
View file

@ -400,43 +400,85 @@ It is an image under the mapping EXTRACT."
(else #f))) (else #f)))
(define-public (arity obj) (define-public (arity obj)
(let ((arity (procedure-property obj 'arity))) (define (display-arg-list arg-list)
(display (car arity)) (display #\`)
(cond ((caddr arity) (display (car arg-list))
(display " or more")) (let loop ((ls (cdr arg-list)))
((not (zero? (cadr arity))) (cond ((null? ls)
(display " required and ") (display #\'))
(display (cadr arity)) ((not (pair? ls))
(display " optional"))) (display "', the rest in `")
(if (and (not (caddr arity)) (display ls)
(= (car arity) 1) (display #\'))
(<= (cadr arity) 1)) (else
(display " argument") (if (pair? (cdr ls))
(display " arguments")) (display "', `")
(if (closure? obj) (display "' and `"))
(let ((formals (cadr (procedure-source obj)))) (display (car ls))
(if (pair? formals) (loop (cdr ls))))))
(begin (define (display-arg-list/summary arg-list type)
(display ": `") (let ((len (length arg-list)))
(display (car formals)) (display len)
(let loop ((ls (cdr formals))) (display " ")
(cond ((null? ls) (display type)
(display #\')) (if (> len 1)
((not (pair? ls)) (display " arguments: ")
(display "', the rest in `") (display " argument: "))
(display ls) (display-arg-list arg-list)))
(display #\')) (cond
(else ((procedure-property obj 'arglist)
(if (pair? (cdr ls)) => (lambda (arglist)
(display "', `") (let ((required-args (car arglist))
(display "' and `")) (optional-args (cadr arglist))
(display (car ls)) (keyword-args (caddr arglist))
(loop (cdr ls)))))) (allow-other-keys? (cadddr arglist))
(begin (rest-arg (car (cddddr arglist)))
(display " in `") (need-punctuation #f))
(display formals) (cond ((not (null? required-args))
(display #\'))))) (display-arg-list/summary required-args "required")
(display ".\n"))) (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 (define-public system-module
(procedure->syntax (procedure->syntax