summaryrefslogtreecommitdiff
path: root/scheme
diff options
context:
space:
mode:
authorChaos Eternal <chaos@shlug.org>2017-08-24 01:16:19 +0800
committerChaos Eternal <chaos@shlug.org>2017-08-24 01:16:19 +0800
commit6a83beef6b949bcc51ae56bff7bdb3acf67ae69b (patch)
tree603a5f9518a92b4ecdd793a5936bc4d15944cb28 /scheme
parent993b63096a0b1b40e51fd0133d32998867f54b81 (diff)
downloadgeiser-chez-6a83beef6b949bcc51ae56bff7bdb3acf67ae69b.tar.gz
geiser-chez-6a83beef6b949bcc51ae56bff7bdb3acf67ae69b.tar.bz2
rewritten geiser:eval to fix the following bug:
when eval (make-violation) it shall return: \#<condition &violation> but previous impletement will treat it as an ERROR.
Diffstat (limited to 'scheme')
-rw-r--r--scheme/chez/geiser/geiser.ss53
1 files changed, 29 insertions, 24 deletions
diff --git a/scheme/chez/geiser/geiser.ss b/scheme/chez/geiser/geiser.ss
index e833e47..ca50295 100644
--- a/scheme/chez/geiser/geiser.ss
+++ b/scheme/chez/geiser/geiser.ss
@@ -30,35 +30,40 @@
(define (geiser:eval module form . rest)
rest
- (let* ((try-eval (lambda (x . y)
- (call/cc
- (lambda (k)
- (with-exception-handler
- (lambda (e)
- (k e))
- (lambda ()
- (if (null? y) (eval x)
- (eval x (car y)))
- ))))))
+ (let* ((body (lambda ()
+ (if module
+ (eval form (environment module))
+ (eval form))))
(result-mid (call-with-values
- (lambda () (if module
- (try-eval form (environment module))
- (try-eval form)))
- (lambda (x . y)
- (if (null? y)
- x
- (cons x y)))))
- (result result-mid)
- (error (if (condition? result-mid)
+ (lambda ()
+ (call/cc
+ (lambda (k)
+ (with-exception-handler
+ (lambda (e)
+ (k 'error e))
+ (lambda ()
+ (call-with-values
+ (lambda ()
+ (body))
+ (lambda (x . y)
+ (if (null? y)
+ (k 'single x)
+ (k 'multi (cons x y))))))))))
+ (lambda (t v)
+ (cons t v))))
+ (result (if (eq? (car result-mid) 'error)
+ ""
+ (with-output-to-string
+ (lambda ()
+ (pretty-print (cdr result-mid))))))
+ (error (if (eq? (car result-mid) 'error)
(cons 'error (list
(cons 'key
(with-output-to-string
- (lambda () (display-condition result-mid))))))
+ (lambda () (display-condition (cdr result-mid)))))))
'())))
- (write `((result ,(with-output-to-string
- (lambda ()
- (pretty-print result))))
- (output . "")
+ (write `((result ,result)
+ (output . "")
,error))
(newline)))