mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-06 12:10:28 +02:00
Code Activity

* session.scm (arity): New procedure.

Browse source
This commit is contained in:
Mikael Djurfeldt 1998-11-26 18:04:46 +00:00
parent aa3bdf59ac
commit 4a9f464eff
1 changed files with 39 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

39
ice-9/session.scm
View file

@ -123,3 +123,42 @@
(cond ((procedure? obj) (procedure-source obj)) (cond ((procedure? obj) (procedure-source obj))
((macro? obj) (procedure-source (macro-transformer obj))) ((macro? obj) (procedure-source (macro-transformer obj)))
(else #f))) (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")))