From 7c7c335386134bc1e45cf62fc2755173facc40cc Mon Sep 17 00:00:00 2001
From: Leah Neukirchen <leah@vuxu.org>
Date: Mon, 7 Nov 2022 23:36:43 +0100
Subject: add fail

---
 mew.scm        | 10 +++++++++-
 mew.svnwiki    |  6 ++++++
 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)
-- 
cgit 1.4.1