From 2e880649e4d59346585a5739041822b0c17802d0 Mon Sep 17 00:00:00 2001
From: Chaos Eternal <chaos@shlug.org>
Date: Thu, 24 Aug 2017 01:16:19 +0800
Subject: 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.
---
 scheme/chez/geiser/geiser.ss | 53 ++++++++++++++++++++++++--------------------
 1 file changed, 29 insertions(+), 24 deletions(-)

(limited to 'scheme/chez')

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)))
 
-- 
cgit v1.2.3