matcher: recognize sys:quasi in necessary places.

* match.tl (compile-cons-structure): Recognize quasi in the
middle of cons structure and compile appropriately.
(parse-lambda-match-clause): Recognize quasi in dot
position properly.
(check, check-end): Treat quasi as atom pattern.
(pat-len): Recognize quasi in dotted position.
(non-triv-pat-p): Handle quasi case. Any quasi containing
elements that are lists is nontrivial.

1 files changed, 7 insertions, 7 deletions

diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index ffb09e1c..64f53357 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -312,8 +312,8 @@
            (car-match (compile-match car car-gensym var-list))
            (cdr-match (if (consp cdr)
                         (caseq (car cdr)
-                          ((sys:expr sys:var) (compile-match cdr cdr-gensym
-                                                             var-list))
+                          ((sys:expr sys:var sys:quasi)
+                             (compile-match cdr cdr-gensym var-list))
                           (t (compile-cons-structure cdr cdr-gensym var-list)))
                         (compile-atom-match cdr cdr-gensym var-list)))
            (guard (new match-guard
@@ -666,7 +666,7 @@
                           variadic-pattern args
                           forms body))
       ((proper-list-p args)
-       (let* ((vpos (pos-if (lop meq 'sys:expr 'sys:var) args)))
+       (let* ((vpos (pos-if (lop meq 'sys:expr 'sys:var 'sys:quasi) args)))
          (tree-bind (fixed-pats . variadic-pat) (split args vpos)
            (new lambda-clause
                 orig-syntax args
@@ -764,13 +764,13 @@
 
 (defun check (f op pat)
   (if (or (not (listp pat))
-          (meq (car pat) 'sys:expr 'sys:var))
+          (meq (car pat) 'sys:expr 'sys:var 'sys:quasi))
     (compile-error f "~s: list pattern expected, not ~s" op pat)
     pat))
 
 (defun check-end (f op pat)
   (if (and (listp pat)
-           (meq (car pat) 'sys:expr 'sys:var))
+           (meq (car pat) 'sys:expr 'sys:var 'sys:quasi))
     (compile-error f "~s: list or atom pattern expected, not ~s" op pat)
     pat))
 
@@ -787,7 +787,7 @@
 
 (defun pat-len (f pat)
   (if (consp pat)
-    (let ((var-op-pos (pos-if (op meq 'sys:var 'sys:expr)
+    (let ((var-op-pos (pos-if (op meq 'sys:var 'sys:expr 'sys:quasi)
                               (butlastn 0 pat))))
       (if var-op-pos var-op-pos (len pat)))
     0))
@@ -821,6 +821,7 @@
   (match-case syntax
     ((@(eq 'sys:expr) (@(bindable) . @nil)) t)
     ((@(eq 'sys:var) @(or @(bindable) nil) . @nil) t)
+    ((@(eq 'sys:quasi) . @(some @(consp))) t)
     ((@pat . @rest) (or (non-triv-pat-p pat)
                         (non-triv-pat-p rest)))
     (#R(@from @to) (or (non-triv-pat-p from)
@@ -944,4 +945,3 @@
                 (stringp ,str))
              @(with ,pos 0)
              ,*(quasi-match var-list (normalize args) nil str pos)))))
-