diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2021-01-15 22:01:49 -0800 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2021-01-15 22:01:49 -0800 |
| commit | 165f289b0a028906e574281286bc0e8f98346b6b (patch) | |
| tree | 1ee2e1cedcf587516e94c7cf943582b9eccb508f /share | |
| parent | ec5a5e9d846e4af1d2311ab37b13ecb7d596e490 (diff) | |
| download | txr-165f289b0a028906e574281286bc0e8f98346b6b.tar.gz txr-165f289b0a028906e574281286bc0e8f98346b6b.tar.bz2 txr-165f289b0a028906e574281286bc0e8f98346b6b.zip | |
matcher: add if-match and match-case.
* lisplib.c (match_set_entries): Add match-case and if-match
autoload trigger symbols.
* share/txr/stdlib/match.tl (if-match, match-case): New
macros.
Diffstat (limited to 'share')
| -rw-r--r-- | share/txr/stdlib/match.tl | 34 |
1 files changed, 34 insertions, 0 deletions
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl index 423cbc9c..695a0310 100644 --- a/share/txr/stdlib/match.tl +++ b/share/txr/stdlib/match.tl @@ -260,3 +260,37 @@ ,cm.(wrap-guards ^(progn ,*cm.(assignments) (if ,cm.test-expr ,*body)))))) + +(defmacro if-match (:form *match-form* pat obj then : else) + (let ((cm (compile-match pat)) + (match-p (gensym "match-p-")) + (result (gensym "result-"))) + ^(let ((,cm.obj-var ,obj) + ,match-p + ,*cm.(get-vars)) + (let ((,result ,cm.(wrap-guards + ^(progn ,*cm.(assignments) + (when ,cm.test-expr + (set ,match-p t) + ,then))))) + (if ,match-p ,result ,else))))) + +(defmacro match-case (:form *match-form* obj . clauses) + (unless [all clauses [andf proper-listp [chain len plusp]]] + (compile-error *match-form* "bad clause syntax")) + (let* ((flag (gensym "flag-")) + (result (gensym "result-")) + (clause-matches [mapcar (op compile-match (car @1) obj) clauses]) + (clause-code (collect-each ((cl clauses) + (cm clause-matches)) + (tree-bind (match . forms) cl + ^(unless ,flag + (let (,*cm.(get-vars)) + (set ,result ,cm.(wrap-guards + ^(progn ,*cm.(assignments) + (when ,cm.test-expr + (set ,flag t) + ,*forms)))))))))) + ^(let (,flag ,result) + ,*clause-code + ,result))) |