summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-08-13 06:25:50 -0700
committerKaz Kylheku <kaz@kylheku.com>2021-08-13 06:25:50 -0700
commit483e15d9af31110d2a34ad20fe010663de5afe19 (patch)
tree6721ce5ccadde9b844ec674bff3145941fa0da17
parent3d7e614022c19d0c42ff32d60c8e51b226fb427d (diff)
downloadtxr-483e15d9af31110d2a34ad20fe010663de5afe19.tar.gz
txr-483e15d9af31110d2a34ad20fe010663de5afe19.tar.bz2
txr-483e15d9af31110d2a34ad20fe010663de5afe19.zip
matcher: new must-match and must-match-case macros.
* lisplib.c (match_set_entries): Intern the match-error symbol. Register autoloads for must-match and must-match-case. * stdlib/match.tl (match-error): Register exception symbol, as subtype of match-error. (must-match, must-match-case): New macros. * tests/011/patmatch.tl: Test cases. * txr.1: Documented.
-rw-r--r--lisplib.c5
-rw-r--r--stdlib/match.tl15
-rw-r--r--tests/011/patmatch.tl9
-rw-r--r--txr.131
4 files changed, 55 insertions, 5 deletions
diff --git a/lisplib.c b/lisplib.c
index 86f20ab1..d777c717 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -877,11 +877,12 @@ static val match_instantiate(val set_fun)
static val match_set_entries(val dlt, val fun)
{
val name_noload[] = {
- lit("all*"), lit("as"), lit("with"), lit("scan"), lit("sme"),
+ lit("all*"), lit("as"), lit("with"), lit("scan"), lit("sme"), lit("match-error"),
nil
};
val name[] = {
- lit("when-match"), lit("match-case"), lit("if-match"),
+ lit("when-match"), lit("match-case"), lit("if-match"), lit("must-match"),
+ lit("must-match-case"),
lit("while-match"), lit("while-match-case"), lit("while-true-match-case"),
lit("lambda-match"), lit("defun-match"), lit("defmatch"),
lit("each-match"), lit("append-matches"),
diff --git a/stdlib/match.tl b/stdlib/match.tl
index 3502688b..d122d24c 100644
--- a/stdlib/match.tl
+++ b/stdlib/match.tl
@@ -28,6 +28,8 @@
(defvar *match-macro* (hash))
+(defex match-error eval-error)
+
(defstruct match-guard ()
temps
vars
@@ -643,6 +645,13 @@
,result
,else)))))
+(defmacro must-match (pat obj . body)
+ (with-gensyms (val)
+ ^(let ((,val ,obj))
+ (if-match ,pat ,val
+ (progn ,*body)
+ (throwf 'match-error "~s: ~s failed to match object ~s" 'must-match ',pat ,val)))))
+
(defmacro while-match (:form *match-form* :env e pat obj . body)
(let ((cm (compile-match pat : (get-var-list e))))
^(for ()
@@ -674,6 +683,12 @@
(or ,*clause-code)
,result-temp))))
+(defmacro must-match-case (obj . clauses)
+ (with-gensyms (else)
+ ^(match-case ,obj
+ ,*clauses
+ ((var ,else) (throwf 'match-error "~s: failed to match object ~s" 'must-match-case ,else)))))
+
(defmacro while-match-case (:form *match-form* :env e obj . clauses)
(unless [all clauses [andf proper-listp [chain len plusp]]]
(compile-error *match-form* "bad clause syntax"))
diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl
index 9647c52b..c6b67614 100644
--- a/tests/011/patmatch.tl
+++ b/tests/011/patmatch.tl
@@ -513,6 +513,15 @@
(@else (error "unhandled case")))))
(:odd 1 :pair 2 3 :even 4 :pair 5 6))
+(mtest
+ (must-match (@a @b) '(1 2) (list a b)) (1 2)
+ (must-match (@a @b) '(1 2 3) (list a b)) :error)
+
+(mtest
+ (must-match-case 42) :error
+ (must-match-case 42 (@a a)) 42
+ (must-match-case '(1 2) ((@a) a)) :error)
+
(compile-only
(eval-only
(compile-file (base-name *load-path*) "temp.tlo")
diff --git a/txr.1 b/txr.1
index da7fa75b..73fb7a83 100644
--- a/txr.1
+++ b/txr.1
@@ -43086,14 +43086,16 @@ apply accordingly.
.SS* Pattern-Matching Macros
-.coNP Macros @ when-match and @ if-match
+.coNP Macros @, when-match @ must-match and @ if-match
.synb
.mets (when-match < pattern < expr << form *)
+.mets (must-match < pattern < expr << form *)
.mets (if-match < pattern < expr < then-form <> [ else-form ])
.syne
.desc
The
-.code when-match
+.codn when-match ,
+.code must-match
and
.code if-match
macros conditionally evaluate code based on whether the value of
@@ -43119,6 +43121,15 @@ If the match fails, the forms are not evaluated, and
is produced.
The
+.code must-match
+macro behaves exactly like
+.code when-match
+when the match is successful. When the match fails,
+.code must-match
+throws an exception of type
+.codn match-error .
+
+The
.code if-match
macro evaluates
.meta then-form
@@ -43131,9 +43142,10 @@ which defaults to
.code nil
if it is not specified.
-.coNP Macro @ match-case
+.coNP Macros @ match-case and @ must-match-case
.synb
.mets (match-case < expr >> {( pattern << form *)}*)
+.mets (must-match-case < expr >> {( pattern << form *)}*)
.syne
.desc
The
@@ -43177,6 +43189,19 @@ or else
.code nil
if there are no forms.
+The
+.code must-match-case
+macro differs from
+.code match-case
+as follows. When none of the clauses match under
+.codn match-case ,
+then that form terminates with a value of
+.codn nil .
+In the same situation, the
+.code must-match-case
+form throws an exception of type
+.codn match-error .
+
.TP* Examples:
.verb