mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-01 01:40:21 +02:00
(arity): Use new `arglist' procedure property to
present a more detailed argument list.
This commit is contained in:
parent
8d41ec9d0f
commit
4d23670ec4
1 changed files with 79 additions and 37 deletions
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue