[nongnu] elpa/geiser-chez e038c28 09/37: more reduction on geiser:eval, add test

[Philip Kaludercic]

branch: elpa/geiser-chez
commit e038c289b15d6895c78d7694c12e75129bd2f4aa
Author: Chaos Eternal <chaos@shlug.org>
Commit: Chaos Eternal <chaos@shlug.org>

    more reduction on geiser:eval, add test
---
 scheme/chez/geiser/geiser.ss | 58 +++++++++++++---------------
 scheme/chez/geiser/test.ss   | 90 ++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 117 insertions(+), 31 deletions(-)

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)
diff --git a/scheme/chez/geiser/test.ss b/scheme/chez/geiser/test.ss
new file mode 100644
index 0000000..ac5503b
--- /dev/null
+++ b/scheme/chez/geiser/test.ss
@@ -0,0 +1,90 @@
+(import (geiser)
+       (chezscheme))
+
+
+(define-syntax get-result
+  (syntax-rules ()
+    ((_ form)
+     (with-output-to-string
+       (lambda ()
+        (geiser:eval #f form))))))
+
+(define-syntax do-test
+  (syntax-rules ()
+    ((_ form result)
+     (assert
+      (equal?
+       (get-result form)
+       result)))))
+
+;; (something-doesnot-exist)
+;;=> Error: Exception: variable something-doesnot-exist is not bound
+(do-test
+ '(something-doesnot-exist)
+ "((result \"\") (output . \"\") (error (key . \"Exception: variable 
something-doesnot-exist is not bound\")))\n"
+ )
+
+;; (make-violation)
+;;=> #<condition &violation>
+(do-test
+ '(make-violation) 
+ "((result \"#<condition &violation>\\n\") (output . \"\"))\n")
+
+;; (values 1 2 3)
+;;==> (1 2 3)
+(do-test
+ '(values 1 2 3)
+ "((result \"(1 2 3)\\n\") (output . \"\"))\n")
+
+;; 1
+;;=> 1
+(do-test '1 "((result \"1\\n\") (output . \"\"))\n")
+
+
+;; '(case-lambda
+;;    [(x1 x2) (+ x1 x2)]
+;;    [(x1 x2 x3) (+ (+ x1 x2) x3)]
+;;    [(x1 x2 . rest)
+;;     ((letrec ([loop (lambda (x1 x2 rest)
+;;                   (let ([x (+ x1 x2)])
+;;                     (if (null? rest)
+;;                         x
+;;                         (loop x (car rest) (cdr rest)))))])
+;;        loop)
+;;      x1
+;;      x2
+;;      rest)]
+;;    [(x1) (+ x1)]
+;;    [() (+)])
+#|=> (case-lambda
+  [(x1 x2) (+ x1 x2)]
+  [(x1 x2 x3) (+ (+ x1 x2) x3)]
+  [(x1 x2 . rest)
+   ((letrec ([loop (lambda (x1 x2 rest)
+                     (let ([x (+ x1 x2)])
+                       (if (null? rest)
+                           x
+                           (loop x (car rest) (cdr rest)))))])
+      loop)
+     x1
+     x2
+     rest)]
+  [(x1) (+ x1)]
+  [() (+)])
+  |#
+(do-test (quote '(case-lambda
+  [(x1 x2) (+ x1 x2)]
+  [(x1 x2 x3) (+ (+ x1 x2) x3)]
+  [(x1 x2 . rest)
+   ((letrec ([loop (lambda (x1 x2 rest)
+                     (let ([x (+ x1 x2)])
+                       (if (null? rest)
+                           x
+                           (loop x (car rest) (cdr rest)))))])
+      loop)
+     x1
+     x2
+     rest)]
+  [(x1) (+ x1)]
+  [() (+)])) "((result \"(case-lambda\\n  [(x1 x2) (+ x1 x2)]\\n  [(x1 x2 x3) 
(+ (+ x1 x2) x3)]\\n  [(x1 x2 . rest)\\n   ((letrec ([loop (lambda (x1 x2 
rest)\\n                     (let ([x (+ x1 x2)])\\n                       (if 
(null? rest)\\n                           x\\n                           (loop 
x (car rest) (cdr rest)))))])\\n      loop)\\n     x1\\n     x2\\n     
rest)]\\n  [(x1) (+ x1)]\\n  [() (+)])\\n\") (output . \"\"))\n")
+