From e038c289b15d6895c78d7694c12e75129bd2f4aa Mon Sep 17 00:00:00 2001
From: Chaos Eternal <chaos@shlug.org>
Date: Thu, 24 Aug 2017 18:54:20 +0800
Subject: more reduction on geiser:eval, add test

---
 scheme/chez/geiser/geiser.ss | 58 +++++++++++++++++++++-----------------------
 1 file changed, 27 insertions(+), 31 deletions(-)

(limited to 'scheme/chez/geiser/geiser.ss')

diff --git a/scheme/chez/geiser/geiser.ss b/scheme/chez/geiser/geiser.ss
index ca50295..8b9aba7 100644
--- a/scheme/chez/geiser/geiser.ss
+++ b/scheme/chez/geiser/geiser.ss
@@ -34,37 +34,33 @@
 		   (if module
 		       (eval form (environment module))
 		       (eval form))))
-	   (result-mid (call-with-values
-			   (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 (cdr result-mid)))))))
-		      '())))
-      (write `((result ,result)
-	       (output . "")
-	       ,error))
+	   (gen-result (lambda (result-mid is-error?)
+			 (if is-error?
+			     `((result "")
+			       (output . "")
+			       (error . ,(list
+					(cons 'key
+					      (with-output-to-string
+						(lambda ()
+						  (display-condition result-mid)))))))
+			     `((result ,(with-output-to-string
+					  (lambda ()
+					    (pretty-print result-mid))))
+			       (output . "")))))
+	   (result (call/cc
+		    (lambda (k)
+		      (with-exception-handler
+			  (lambda (e)
+			    (k (gen-result e #t)))
+			(lambda ()
+			  (call-with-values
+			      (lambda ()
+				(body))
+			    (lambda (x . y)
+			      (if (null? y)
+				  (k (gen-result x #f))
+				  (k (gen-result (cons x y) #f)))))))))))
+      (write result)
       (newline)))
 
   (define (geiser:module-completions prefix . rest)
-- 
cgit v1.2.3