summaryrefslogtreecommitdiff
path: root/scheme/plt
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2009-09-26 21:44:21 +0200
committerJose Antonio Ortega Ruiz <jao@gnu.org>2009-09-26 21:44:21 +0200
commitf2f267955c46d110da4c75a5972f021a2c715a6c (patch)
tree642ee19a130a8d87b22e284643ca7d4a6d5e5ef9 /scheme/plt
parentf67ef229256de7406666dd5ffe14c229bf0b2045 (diff)
downloadgeiser-guile-f2f267955c46d110da4c75a5972f021a2c715a6c.tar.gz
geiser-guile-f2f267955c46d110da4c75a5972f021a2c715a6c.tar.bz2
Multiple arity display, used by PLT backend (case-lambda).
Diffstat (limited to 'scheme/plt')
-rw-r--r--scheme/plt/geiser/autodoc.ss57
1 files changed, 34 insertions, 23 deletions
diff --git a/scheme/plt/geiser/autodoc.ss b/scheme/plt/geiser/autodoc.ss
index ef73cc1..c349f6e 100644
--- a/scheme/plt/geiser/autodoc.ss
+++ b/scheme/plt/geiser/autodoc.ss
@@ -31,11 +31,12 @@
(let* ((loc (symbol-location* id))
(name (car loc))
(path (cdr loc))
- (sgn (and path (find-signature path name id))))
- (and sgn
+ (sgns (and path (find-signatures path name id)))
+ (sgns (if (list? sgns) sgns '())))
+ (and sgns
`(,id
(name . ,name)
- (args ,@(format-signature sgn))
+ (args ,@(map format-signature sgns))
(module . ,(module-path-name->name path)))))))
(define (format-signature sign)
@@ -51,11 +52,11 @@
(define-struct signature (required optional keys rest))
-(define (find-signature path name local-name)
+(define (find-signatures path name local-name)
(let ((path (if (path? path) (path->string path) path)))
(hash-ref! (hash-ref! signatures path (lambda () (parse-signatures path)))
name
- (lambda () (infer-signature local-name)))))
+ (lambda () (infer-signatures local-name)))))
(define (parse-signatures path)
(let ((result (make-hasheq)))
@@ -82,6 +83,8 @@
(add-signature! name formals store))
((list 'define name (list 'lambda formals body ...))
(add-signature! name formals store))
+ ((list 'define name (list 'case-lambda forms ...))
+ (for-each (lambda (f) (parse-datum! (list 'define name (cons 'lambda f)))) forms))
((list 'define-for-syntax (list name formals ...) body ...)
(add-signature! name formals store))
((list 'define-for-syntax name (list 'lambda formals body ...))
@@ -92,7 +95,10 @@
(define (add-signature! name formals store)
(when (symbol? name)
- (hash-set! store name (parse-formals formals))))
+ (hash-set! store
+ name
+ (cons (parse-formals formals)
+ (hash-ref store name '())))))
(define (parse-formals formals)
(let loop ((formals formals) (req '()) (opt '()) (keys '()))
@@ -115,38 +121,43 @@
(cons name keys))))
(else (loop (cdr formals) (cons (car formals) req) opt keys)))))
-(define (infer-signature name)
+(define (infer-signatures name)
(define syntax-tag (cons 1 0))
(define error-tag (cons 1 1))
(define generic-signature (make-signature '(...) '() '() #f))
(let ((value (with-handlers ((exn:fail:syntax? (lambda (_) syntax-tag))
(exn:fail:contract:variable? (lambda (_) error-tag)))
(namespace-variable-value name))))
- (cond ((procedure? value)
- (arity->signature (procedure-arity value)))
- ((eq? value syntax-tag) generic-signature)
+ (cond ((procedure? value) (arity->signatures (procedure-arity value)))
+ ((eq? value syntax-tag) (list generic-signature))
((eq? value error-tag) #f)
(else 'variable))))
-(define (arity->signature arity)
+(define (arity->signatures arity)
(define (args fst count)
(let* ((letts (list->vector '(#\x #\y #\z #\u #\v #\w #\r #\s)))
(len (vector-length letts))
(lett (lambda (n) (vector-ref letts (modulo n len)))))
(map (lambda (n) (string->symbol (format "~a" (lett n))))
(build-list count (lambda (n) (+ n fst))))))
- (cond ((number? arity)
- (make-signature (args 0 arity) '() '() #f))
- ((arity-at-least? arity)
- (make-signature (args 0 (arity-at-least-value arity)) '() '() 'rest))
- (else
- (let* ((arg-nos (map (lambda (a)
- (if (number? a) a (arity-at-least-value a)))
- arity))
- (min-val (apply min arg-nos))
- (max-val (apply max arg-nos))
- (opt-no (- max-val min-val)))
- (make-signature (args 0 min-val) (args min-val opt-no) '() #f)))))
+ (define (arity->signature arity)
+ (cond ((number? arity)
+ (make-signature (args 0 arity) '() '() #f))
+ ((arity-at-least? arity)
+ (make-signature (args 0 (arity-at-least-value arity)) '() '() 'rest))))
+ (define (conseq? lst)
+ (cond ((< (length lst) 2) (number? (car lst)))
+ ((and (number? (car lst))
+ (number? (cadr lst))
+ (eqv? (+ 1 (car lst)) (cadr lst)))
+ (conseq? (cdr lst)))
+ (else #f)))
+ (cond ((and (list? arity) (conseq? arity))
+ (let ((mi (apply min arity))
+ (ma (apply max arity)))
+ (list (make-signature (args 0 mi) (args mi (- ma mi)) '() #f))))
+ ((list? arity) (map arity->signature arity))
+ (else (list (arity->signature arity)))))
(define (update-module-cache path . form)
(when (and (string? path)