summaryrefslogtreecommitdiff
path: root/scheme/guile
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2009-02-28 00:42:42 +0100
committerJose Antonio Ortega Ruiz <jao@gnu.org>2009-02-28 00:42:42 +0100
commit12aef24d0084a3739e9433b10398304261074066 (patch)
treeda948c23b0b746a14473b06c4b44e58288af9fdc /scheme/guile
parent20811cf28fd0496acbd2d3fe9050d8c9892470a7 (diff)
downloadgeiser-guile-12aef24d0084a3739e9433b10398304261074066.tar.gz
geiser-guile-12aef24d0084a3739e9433b10398304261074066.tar.bz2
Put new procedure-arguments into (geiser introspection) until it goes upstream.
Diffstat (limited to 'scheme/guile')
-rw-r--r--scheme/guile/geiser/introspection.scm38
1 files changed, 37 insertions, 1 deletions
diff --git a/scheme/guile/geiser/introspection.scm b/scheme/guile/geiser/introspection.scm
index 4b833d5..0394926 100644
--- a/scheme/guile/geiser/introspection.scm
+++ b/scheme/guile/geiser/introspection.scm
@@ -98,7 +98,7 @@
(define (obj-args obj)
(cond ((not obj) #f)
- ((or (procedure? obj) (program? obj)) (procedure-arguments obj))
+ ((or (procedure? obj) (program? obj)) (arguments obj))
((macro? obj) (or (obj-args (macro-transformer obj))
'((required ...))))
(else #f)))
@@ -113,6 +113,42 @@
(regexp-quote (symbol->string sym))
(apropos-fold-accessible (current-module)))))))
+(define (gen-arg-names fst count)
+ (map (lambda (n) (string->symbol (format "arg-~A" (+ fst n))))
+ (iota (max count 1))))
+
+(define (arguments proc)
+ "Return an alist describing the arguments that `proc' accepts, or `#f'
+if the information cannot be obtained.
+
+The alist keys that are currently defined are `required', `optional',
+`keyword', and `rest'."
+ (cond
+ ((procedure-property proc 'arglist)
+ => (lambda (arglist)
+ `((required . ,(car arglist))
+ (optional . ,(cadr arglist))
+ (keyword . ,(caddr arglist))
+ (rest . ,(car (cddddr arglist))))))
+ ((procedure-source proc)
+ => (lambda (src)
+ (let ((formals (cadr src)))
+ (cond ((list? formals) `((required . ,formals)))
+ ((pair? formals)
+ `((required . ,(car formals)) (rest . ,(cdr formals))))
+ (else #f)))))
+ (((@ (system vm program) program?) proc)
+ ((@ (system vm program) program-arguments) proc))
+ ((procedure-property proc 'arity)
+ => (lambda (art)
+ (let ((req (car art))
+ (opt (cadr art))
+ (rest (caddr art)))
+ `(,@(if (> req 0) (list (cons 'required (gen-arg-names 1 req))) '())
+ ,@(if (> opt 0) (list (cons 'optional (gen-arg-names (+ 1 req) opt))) '())
+ ,@(if rest (list (cons 'rest 'rest)) '())))))
+ (else #f)))
+
(define (completions prefix)
(sort! (map symbol->string
(apropos-internal (string-append "^" prefix)))