mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-21 11:10:21 +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:16:42 +00:00
parent 8d41ec9d0f
commit 4d23670ec4
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)))
(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