summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorjao <jao@gnu.org>2022-10-09 03:22:44 +0100
committerjao <jao@gnu.org>2022-10-09 03:30:14 +0100
commit52fbf028e5cee83453a011e43daeab524a2fd9e6 (patch)
treeb20abecb9cfaf86ab11bce45195806c877c1037a /src
parent0cd37833aba3af0150ea4486e244cd38f376f1cd (diff)
downloadgeiser-chez-52fbf028e5cee83453a011e43daeab524a2fd9e6.tar.gz
geiser-chez-52fbf028e5cee83453a011e43daeab524a2fd9e6.tar.bz2
fixes for the above in the face of non-continuable conditions
Diffstat (limited to 'src')
-rw-r--r--src/geiser/geiser.ss32
1 files changed, 23 insertions, 9 deletions
diff --git a/src/geiser/geiser.ss b/src/geiser/geiser.ss
index f20434b..3a5fc9f 100644
--- a/src/geiser/geiser.ss
+++ b/src/geiser/geiser.ss
@@ -71,9 +71,7 @@
(environment-symbols (interaction-environment))))))
(define (write-to-string x)
- (with-output-to-string
- (lambda ()
- (write x))))
+ (with-output-to-string (lambda () (write x))))
(define (geiser:eval module form)
(call-with-result
@@ -97,12 +95,13 @@
(define (arity->parameter-list p)
(define (nparams n)
(map (lambda (n) (string->symbol (format "x~a" n))) (iota n)))
+ (define (add-opt pl)
+ (cons (append (if (null? pl) '() (car pl)) '(...)) pl))
(let* ((m (procedure-arity-mask p))
(pm (if (< m 0) (+ 1 (lognot m)) m))
(n (if (> pm 0) (/ (log pm) (log 2)) 0)))
(let loop ((k 1) (pl '()))
- (cond ((> k n)
- (reverse (if (< m 0) (cons (append (car pl) '(...)) pl) pl)))
+ (cond ((> k n) (reverse (if (< m 0) (add-opt pl) pl)))
((logbit? k pm) (loop (+ k 1) (cons (nparams k) pl)))
(else (loop (+ k 1) pl))))))
@@ -129,6 +128,22 @@
(list (vector->list (record-type-field-names rtd))))]
[else #f]))))
+ (define (value->string x)
+ (define max-len 80)
+ (define sub-str "...")
+ (define sub-len (- max-len (string-length sub-str)))
+ (let* ((s (write-to-string x))
+ (l (string-length s)))
+ (if (<= l max-len) s (string-append (substring s 0 sub-len) sub-str))))
+
+ (define not-found (gensym))
+
+ (define (try-eval sym)
+ (call/cc
+ (lambda (k)
+ (with-exception-handler (lambda (e) (k not-found))
+ (lambda () (eval sym))))))
+
(define (operator-arglist operator)
(define (procedure-parameter-list p)
(and (procedure? p)
@@ -140,13 +155,12 @@
(else `(("required" . ,(reverse req))
("optional" ,args)))))
(define (autodoc-arglist arglist) (autodoc-arglist* arglist '()))
- (let ([binding (with-exception-handler (lambda (e) #f)
- (lambda () (eval operator)))])
- (if binding
+ (let ([binding (try-eval operator)])
+ (if (not (eq? binding not-found))
(let ([arglists (procedure-parameter-list binding)])
(if arglists
`(,operator ("args" ,@(map autodoc-arglist arglists)))
- `(,operator ("value" . ,(write-to-string binding)))))
+ `(,operator ("value" . ,(value->string binding)))))
'())))
(define (geiser:autodoc ids . rest)