diff options
| -rw-r--r-- | mew.scm | 10 | ||||
| -rw-r--r-- | mew.svnwiki | 6 | ||||
| -rw-r--r-- | tests/test.mew | 16 |
3 files changed, 30 insertions, 2 deletions
diff --git a/mew.scm b/mew.scm index 4e060a4..6ae2e6d 100644 --- a/mew.scm +++ b/mew.scm @@ -5,7 +5,7 @@ comp dec def del-at div empty? eof esc - fin final for fun* + fail fin final for fun* gconcatenate gen generic-for-each genumerate get gfix giterate gmatch gpick group-by-accumulator gslice-when gsplit gwindow inc inject into @@ -38,6 +38,7 @@ (print puts) (complement negate) (compose comp)) + (chicken condition) (chicken module) (chicken port) (chicken repl) @@ -788,6 +789,13 @@ ((_ 3) (lambda (a b c d . args) d)) ((_ n) (lambda args (list-ref args n))))) + (define (fail exn . args) + (if (list? exn) + (signal (apply condition + (list (car exn) 'message (apply format args)) + (map list (cdr exn)))) + (apply fail '(exn) exn args))) + (let ((old-repl-prompt (repl-prompt))) (repl-prompt (lambda () (let ((old-prompt (old-repl-prompt))) diff --git a/mew.svnwiki b/mew.svnwiki index 3ddcc9b..0aeed8c 100644 --- a/mew.svnwiki +++ b/mew.svnwiki @@ -128,6 +128,12 @@ Evaluate {{<expr>}} while {{<cond>}} is true/false. Like {{cond}}, but raise error if no case matched. +<syntax>(fail <type>? <message> <args>...)</syntax> + +Create and signal a condition of {{<type>}} (default: {{(exn)}}) +with a {{'message}} of {{<message>}} passed through {{format}} with +{{<args>}}. + == Numeric helpers diff --git a/tests/test.mew b/tests/test.mew index 903620c..98ad5fa 100644 --- a/tests/test.mew +++ b/tests/test.mew @@ -1,6 +1,7 @@ (import mew test - (chicken port)) + (chicken port) + (chicken condition)) (test-group "negate" (test #t ((negate not) #t)) @@ -477,4 +478,17 @@ (test 3 ((proj 2) 1 2 3)) (test-error ((proj 4) 1 2 3))) +(test-group "fail" + (test #t (condition-case (fail "foo") + ((exn) #t) + (() #f))) + (test #t (condition-case (fail '(florp) "foo") + ((florp) #t) + (() #f))) + (test #t (condition-case (fail '(florp flurp) "foo") + ((florp flurp) #t) + (() #f))) + (test "foo 1 2" (condition-case (fail "foo ~a ~a" 1 2) + (e (exn) (get-condition-property e 'exn 'message))))) + (test-exit) |