From ded91d9741b8ef3c356de2455e02b7df80685b42 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Sun, 25 Apr 2021 00:20:27 -0700 Subject: 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. --- share/txr/stdlib/match.tl | 14 +++++++------- 1 file 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))))) - -- cgit v1.2.3