matcher: new quasiliteral matching macro.

* share/txr/stdlib/match.tl (sys:quasi): New defmatch.
This is a macro for now, which makes it require the @ prefix:
e.g. @`@a-@b-@c`. The plain is to integrate this into the
matcher to eliminate that @ prefix. The first priority
are test cases and documentation.

1 files changed, 109 insertions, 0 deletions

diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index 08357932..f6d57e1e 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -813,6 +813,115 @@
           @(with @(as ,(check-sym f 'end evar t) ,pend)
                  (nthlast ,lend ,obj)))))
 
+(defmatch sys:quasi (:form f :env env . args)
+  (labels ((bound-p (env vars sym)
+             (cond
+               ((bindable sym) (or (member sym vars) (lexical-var-p env sym)))
+               ((null sym) t)
+               ((compile-error f "bindable symbol expected, not ~s" sym))))
+           (normalize (args)
+             (mapcar (do if-match (@(eq 'sys:var) @sym nil) @1
+                       ^(sys:var ,sym)
+                       @1)
+                     args))
+           (quasi-match (env args vars str pos)
+             (match-case args
+               ;; `text`
+               ((@(stringp @txt))
+                (list ^@(require @nil (str= ,txt (sub-str ,str ,pos t)))))
+               ;; `txt@...`
+               ((@(stringp @txt) . @rest)
+                (with-gensyms (npos)
+                  (cons ^@(require @(with ,npos ,(len txt))
+                            (starts-with ,txt ,str))
+                        (quasi-match env rest vars str npos))))
+               ;; `@var` (existing binding)
+               (((@(eq 'sys:var) @(bound-p env vars @sym) . @nil))
+                (list ^@(require @nil (str= (sys:quasi ,(car args))
+                                            (sub-str ,str ,pos t)))))
+               ;; `@var@...` (existing binding)
+               (((@(eq 'sys:var) @(bound-p env vars @sym) . @nil) . @rest)
+                (with-gensyms (txt len npos)
+                  (list* ^@(with ,txt (sys:quasi ,(car args)))
+                         ^@(with ,len (len ,txt))
+                         ^@(with ,npos (+ ,pos ,len))
+                         ^@(require @nil
+                             (str= ,txt (sub-str ,str ,pos ,npos)))
+                         (quasi-match env (cdr args) vars str npos))))
+               ;; `@var` (new binding)
+               (((@(eq 'sys:var) @sym))
+                (list ^@(with ,sym (sub-str ,str ,pos t))))
+               ;; `@{var #/rx/}` (new binding)
+               (((@(eq 'sys:var) @sym (@(regexp @reg))))
+                (list ^@(require @(with ,sym (sub-str ,str ,pos t))
+                          (m^$ ,reg ,sym))))
+               ;; `@{var #/rx/}@...` (new binding)
+               (((@(eq 'sys:var) @sym (@(regexp @reg))) . @rest)
+                (with-gensyms (len npos)
+                  (list* ^@(require @(with ,len (match-regex ,str ,reg ,pos))
+                            ,len)
+                         ^@(with ,npos (+ ,pos ,len))
+                         ^@(with ,sym (sub-str ,str ,pos ,npos))
+                         (quasi-match env rest (cons sym vars) str npos))))
+               ;; `@{var 123}` (new binding)
+               (((@(eq 'sys:var) @sym (@(integerp @len))))
+                (unless (plusp len)
+                  (compile-error f "variable ~s: positive integer required, \
+                                   \ not ~a" sym))
+                (with-gensyms (npos)
+                  (list ^@(require @(with ,npos (+ ,pos ,len))
+                            (eql ,npos (len ,str)))
+                        ^@(with ,sym (sub-str ,str ,pos t)))))
+               ;; `@{var 123}@...`` (new binding)
+               (((@(eq 'sys:var) @sym (@(integerp @len))) . @rest)
+                (unless (plusp len)
+                  (compile-error f "variable ~s: positive integer required, \
+                                 \ not ~a" sym))
+                (with-gensyms (npos)
+                  (list* ^@(require @(with ,npos (+ ,pos ,len))
+                             (<= ,npos (len ,str)))
+                         ^@(with ,sym (sub-str ,str ,pos ,npos))
+                         (quasi-match env rest (cons sym vars) str npos))))
+               ;; `@{var}txt` (new binding)
+               (((@(eq 'sys:var) @sym) @(stringp @txt) . @rest)
+                (with-gensyms (len end npos)
+                  (list* ^@(require @(with ,len (search-str ,str ,txt ,pos))
+                            ,len)
+                         ^@(with ,end (+ ,pos ,len))
+                         ^@(with ,npos (+ ,end ,(len txt)))
+                         ^@(with ,sym (sub-str ,str ,pos ,end))
+                         (quasi-match env (cdr rest) (cons sym vars)
+                                      str npos))))
+               ;; `@var0@var1` (unbound followed by bound)
+               (((@(eq 'sys:var) @sym)
+                 (@(eq 'sys:var) @(bound-p env vars @bsym) . @mods)
+                 . @rest)
+                (with-gensyms (txt len end npos)
+                  (list* ^@(with ,txt (sys:quasi ,(cadr args)))
+                         ^@(require @(with ,len (search-str ,str ,txt ,pos))
+                            ,len)
+                         ^@(with ,end (+ ,pos ,len))
+                         ^@(with ,npos (+ ,end (len ,txt)))
+                         ^@(with ,sym (sub-str ,str ,pos ,end))
+                         (quasi-match env (cdr rest) (cons sym vars)
+                                      str npos))))
+               ;; `@{var whatever}@...`(new binding, unsupported modifiers)
+               (((@(eq 'sys:var) @sym @mods . @nil) . @rest)
+                (compile-error f "variable ~s: unsupported modifiers ~s"
+                               sym mods))
+
+               ;; `@var0@var1` (unbound followed by unbound)
+               (((@(eq 'sys:var) @sym0)
+                 (@(eq 'sys:var) @sym1 . @mods)
+                 . @rest)
+                (compile-error f "consecutive unbound variables ~s and ~s"
+                               sym0 sym1)))))
+    (with-gensyms (str pos)
+      ^@(and @(require (sys:var ,str)
+                (stringp ,str))
+             @(with ,pos 0)
+             ,*(quasi-match env (normalize args) nil str pos)))))
+
 (defun non-triv-pat-p (syntax) t)
 
 (defun non-triv-pat-p (syntax)