From da4c55acce0b7272920c40fd2169e233f75f249e Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Sun, 7 Feb 2021 08:48:05 -0800 Subject: matcher: exprs-syntax: process trivial matches first. * share/txr/stdlib/match.tl (compile-exprs-match): Sort the expressions and patterns so trivial matches are processed first. The original order is used for evaluating the expressions. --- share/txr/stdlib/match.tl | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl index 2ed436d7..0aea24b2 100644 --- a/share/txr/stdlib/match.tl +++ b/share/txr/stdlib/match.tl @@ -523,18 +523,21 @@ obj-var obj-var guard-chain (cons guard (mappend .guard-chain hash-matches)))))) -(defun compile-exprs-match (exprs-syntax exprs var-list) - (let ((pats (cdr exprs-syntax)) - (temps (mapcar (ret (gensym)) exprs))) - (let* ((matches (mapcar (op compile-match @1 @2 var-list) - pats temps))) - (new compiled-match - pattern exprs-syntax - obj-var nil - guard-chain (cons (new match-guard - pure-temps temps - pure-temp-exprs exprs) - (mappend .guard-chain matches)))))) +(defun compile-exprs-match (exprs-syntax uexprs var-list) + (let ((upats (cdr exprs-syntax)) + (utemps (mapcar (ret (gensym)) uexprs))) + (tree-bind (pats temps exprs) (multi-sort (list upats utemps uexprs) + [list less] + [list non-triv-pat-p]) + (let* ((matches (mapcar (op compile-match @1 @2 var-list) + pats temps))) + (new compiled-match + pattern exprs-syntax + obj-var nil + guard-chain (cons (new match-guard + pure-temps utemps + pure-temp-exprs uexprs) + (mappend .guard-chain matches))))))) (defun compile-match (pat : (obj-var (gensym)) (var-list (new var-list))) (cond -- cgit v1.2.3