diff options
| -rw-r--r-- | lisplib.c | 6 | ||||
| -rw-r--r-- | share/txr/stdlib/match.tl | 6 |
2 files changed, 10 insertions, 2 deletions
@@ -869,11 +869,17 @@ static val match_instantiate(val set_fun) static val match_set_entries(val dlt, val fun) { + val name_noload[] = { + lit("all*"), + nil + }; val name[] = { lit("when-match"), nil }; + set_dlt_entries(dlt, name, fun); + intern_only(name_noload); return nil; } diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl index 4fd3ad41..dd917786 100644 --- a/share/txr/stdlib/match.tl +++ b/share/txr/stdlib/match.tl @@ -163,7 +163,8 @@ (defun compile-all-match (exp obj-var) (tree-bind (op match) exp - (let* ((item-var (gensym "item-")) + (let* ((list-test (if (eq op 'all) 'listp 'consp)) + (item-var (gensym "item-")) (cm (compile-match match item-var)) (all-match-p-var (gensym "all-match-p-")) (matched-p-var (gensym "matched-p-")) @@ -188,7 +189,7 @@ (guard (new match-guard vars (cons all-match-p-var collect-vars) var-exprs (list loop) - guard-expr ^(consp ,obj-var)))) + guard-expr ^(,list-test ,obj-var)))) (new compiled-match pattern exp obj-var obj-var @@ -209,6 +210,7 @@ (require (compile-require-match exp obj-var)) (let (compile-let-match exp obj-var)) (all (compile-all-match exp obj-var)) + (usr:all* (compile-all-match exp obj-var)) (t (compile-predicate-match exp obj-var))) (compile-error *match-form* "unrecognized pattern syntax ~s" pat)))) |