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 | 2e880649e4d59346585a5739041822b0c17802d0 (patch) | |
| tree | f41b86142965496cc587325c23329bf527935ff8 | |
| parent | 9d6d860dcd27fdea3c7a0f76f79863234555cafe (diff) | |
| download | geiser-guile-2e880649e4d59346585a5739041822b0c17802d0.tar.gz geiser-guile-2e880649e4d59346585a5739041822b0c17802d0.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.
| -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))) |