diff options
| author | Chaos Eternal <chaos@shlug.org> | 2017-08-24 01:16:19 +0800 |
|---|---|---|
| committer | Chaos Eternal <chaos@shlug.org> | 2017-08-24 01:16:19 +0800 |
| commit | 6a83beef6b949bcc51ae56bff7bdb3acf67ae69b (patch) | |
| tree | 603a5f9518a92b4ecdd793a5936bc4d15944cb28 /scheme/chez/geiser/geiser.ss | |
| parent | 993b63096a0b1b40e51fd0133d32998867f54b81 (diff) | |
| download | geiser-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/chez/geiser/geiser.ss')
| -rw-r--r-- | scheme/chez/geiser/geiser.ss | 53 |
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))) |