diff options
| -rw-r--r-- | scheme/chez/geiser/geiser.ss | 58 | ||||
| -rw-r--r-- | 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") + |