[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Patch] Better reflection for procedures with optional/key args
From: |
Matthias Koeppe |
Subject: |
[Patch] Better reflection for procedures with optional/key args |
Date: |
Wed, 05 Sep 2001 16:43:24 +0200 |
The procedure ARITY from (ice-9 session) allows to query the arity of
a procedure, including the names of the arguments if they are
available:
guile> (arity display) ; primitive procedure
1 required and 1 optional argument.
guile> (arity apropos)
1 or more arguments: `rgx', the rest in `options'.
However, if one defines procedures having optional or keyword defines,
the result is not very useful:
guile> (use-modules (ice-9 optargs))
guile> (define* (foo #:optional a b c) a)
guile> (arity foo)
0 or more arguments in `lambda*:G0'.
The following patch makes the behaviour of ARITY more useful by
introducing a procedure property ARGLIST, which is set by DEFINE* and
retrieved by ARITY. No change to the handling of ordinary procedures
is made. The result looks like this:
guile> (arity foo)
3 optional arguments: `a', `b' and `c'.
guile> (define* (bar a b #:key c d #:allow-other-keys) a)
guile> (arity bar)
2 required arguments: `a' and `b', 2 keyword arguments: `c'
and `d', other keywords allowed.
guile> (define* (baz a b #:optional c #:rest r) a)
guile> (arity baz)
2 required arguments: `a' and `b', 1 optional argument: `c',
the rest in `r'.
2001-09-05 Matthias Koeppe <address@hidden>
* optargs.scm (lambda*): Record the broken-down argument list in
the `arglist' procedure property.
* session.scm (arity): Use it here to present a more detailed
argument list.
Index: ice-9/optargs.scm
===================================================================
RCS file: /cvs/guile/guile-core/ice-9/optargs.scm,v
retrieving revision 1.14.2.1
diff -u -r1.14.2.1 optargs.scm
--- ice-9/optargs.scm 2001/07/19 20:52:33 1.14.2.1
+++ ice-9/optargs.scm 2001/09/05 14:36:58
@@ -275,27 +275,36 @@
(if (not (or (symbol? rest-arg) (eq? #f rest-arg)))
(error "Syntax error in rest argument declaration."))
;; generate the code.
- (let ((rest-gensym (or rest-arg (gensym "lambda*:G"))))
+ (let ((rest-gensym (or rest-arg (gensym "lambda*:G")))
+ (lambda-gensym (gensym "lambda*:L")))
(if (not (and (null? optionals) (null? keys)))
- `(lambda (,@non-optional-args . ,rest-gensym)
- ;; Make sure that if the proc had a docstring, we put it
- ;; here where it will be visible.
- ,@(if (and (not (null? BODY))
- (string? (car BODY)))
- (list (car BODY))
- '())
- (let-optional*
- ,rest-gensym
- ,optionals
- (let-keywords* ,rest-gensym
- ,aok?
- ,keys
- ,@(if (and (not rest-arg) (null? keys))
- `((if (not (null? ,rest-gensym))
- (error "Too many arguments.")))
- '())
- (let ()
- ,@BODY))))
+ `(let ((,lambda-gensym
+ (lambda (,@non-optional-args . ,rest-gensym)
+ ;; Make sure that if the proc had a docstring, we put it
+ ;; here where it will be visible.
+ ,@(if (and (not (null? BODY))
+ (string? (car BODY)))
+ (list (car BODY))
+ '())
+ (let-optional*
+ ,rest-gensym
+ ,optionals
+ (let-keywords* ,rest-gensym
+ ,aok?
+ ,keys
+ ,@(if (and (not rest-arg) (null? keys))
+ `((if (not (null? ,rest-gensym))
+ (error "Too many arguments.")))
+ '())
+ (let ()
+ ,@BODY))))))
+ (set-procedure-property! ,lambda-gensym 'arglist
+ '(,non-optional-args
+ ,optionals
+ ,keys
+ ,aok?
+ ,rest-arg))
+ ,lambda-gensym)
`(lambda (,@non-optional-args . ,(if rest-arg rest-arg '()))
,@BODY))))))
Index: ice-9/session.scm
===================================================================
RCS file: /cvs/guile/guile-core/ice-9/session.scm,v
retrieving revision 1.30
diff -u -r1.30 session.scm
--- ice-9/session.scm 2001/06/03 23:29:45 1.30
+++ ice-9/session.scm 2001/09/05 14:36:58
@@ -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
--
Matthias Köppe -- http://www.math.uni-magdeburg.de/~mkoeppe
SWIG makes Guile wrappers for C/C++ libs -- http://www.swig.org
ILISP does module-aware Emacs/Guile interaction -- http://ilisp.cons.org
- [Patch] Better reflection for procedures with optional/key args,
Matthias Koeppe <=