summaryrefslogtreecommitdiff
path: root/scheme
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2009-03-02 00:29:55 +0100
committerJose Antonio Ortega Ruiz <jao@gnu.org>2009-03-02 00:29:55 +0100
commit97d1170d4170933a317782dbf353eddf41f09802 (patch)
treecd2c289dfc787a0a6ebacace2bc8a42445fdde6d /scheme
parent28e79842fd87689187834a2c4186b5e2ac294fe6 (diff)
downloadgeiser-chez-97d1170d4170933a317782dbf353eddf41f09802.tar.gz
geiser-chez-97d1170d4170933a317782dbf353eddf41f09802.tar.bz2
Autodoc support for GOOPS methods.
Diffstat (limited to 'scheme')
-rw-r--r--scheme/guile/geiser/introspection.scm91
1 files changed, 56 insertions, 35 deletions
diff --git a/scheme/guile/geiser/introspection.scm b/scheme/guile/geiser/introspection.scm
index de1020f..900a5fa 100644
--- a/scheme/guile/geiser/introspection.scm
+++ b/scheme/guile/geiser/introspection.scm
@@ -36,6 +36,7 @@
#:use-module (ice-9 regex)
#:use-module (ice-9 session)
#:use-module (ice-9 documentation)
+ #:use-module (oop goops)
#:use-module (srfi srfi-1))
(define (autodoc form)
@@ -104,6 +105,16 @@
(if (null? keys) 0 (+ 1 (length keys)))
(if rest 2 0))))))))
+(define (symbol-module sym)
+ (and sym
+ (call/cc
+ (lambda (k)
+ (apropos-fold (lambda (module name var init)
+ (if (eq? name sym) (k (module-name module)) init))
+ #f
+ (regexp-quote (symbol->string sym))
+ (apropos-fold-accessible (current-module)))))))
+
(define (symbol->obj sym)
(and (symbol? sym)
(module-defined? (current-module) sym)
@@ -116,46 +127,56 @@
'((required ...))))
(else #f)))
-(define (symbol-module sym)
- (and sym
- (call/cc
- (lambda (k)
- (apropos-fold (lambda (module name var init)
- (if (eq? name sym) (k (module-name module)) init))
- #f
- (regexp-quote (symbol->string sym))
- (apropos-fold-accessible (current-module)))))))
+(define (arguments proc)
+ (cond
+ ((is-a? proc <generic>) (generic-args proc))
+ ((procedure-property proc 'arglist) => arglist->args)
+ ((procedure-source proc) => source->args)
+ ((program? proc) ((@ (system vm program) program-arguments) proc))
+ ((procedure-property proc 'arity) => arity->args)
+ (else #f)))
+
+(define (source->args src)
+ (let ((formals (cadr src)))
+ (cond ((list? formals) `((required . ,formals)))
+ ((pair? formals)
+ `((required . ,(car formals)) (rest . ,(cdr formals))))
+ (else #f))))
+
+(define (arity->args 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)) '()))))
(define (gen-arg-names fst count)
(map (lambda (n) (string->symbol (format "arg-~A" (+ fst n))))
(iota (max count 1))))
-(define (arguments proc)
- (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 (arglist->args arglist)
+ `((required . ,(car arglist))
+ (optional . ,(cadr arglist))
+ (keyword . ,(caddr arglist))
+ (rest . ,(car (cddddr arglist)))))
+
+(define (generic-args gen)
+ (define (src> src1 src2)
+ (> (length (cadr src1)) (length (cadr src2))))
+ (define (src m)
+ (catch #t
+ (lambda () (method-source m))
+ (lambda (k . a) #f)))
+ (let* ((methods (generic-function-methods gen))
+ (srcs (filter identity (map src methods))))
+ (cond ((and (null? srcs) (null? methods)) '((rest . rest)))
+ ((and (null? srcs)
+ (not (null? methods))
+ (method-procedure (car methods)))
+ => arguments)
+ ((not (null? srcs)) (source->args (car (sort! srcs src>))))
+ (else '((rest . rest))))))
(define (completions prefix . context)
(let ((context (and (not (null? context)) (car context)))