summaryrefslogtreecommitdiffstats
path: root/share
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-04-24 20:26:17 -0700
committerKaz Kylheku <kaz@kylheku.com>2021-04-24 20:26:17 -0700
commit7de6f85f52201269f2890903adf12cf31ffbfbbc (patch)
tree9040af4f0686d505823ea29eb479364922ac559b /share
parent4e32c272c818c01577f42a63e09b01f8b6257fe4 (diff)
downloadtxr-7de6f85f52201269f2890903adf12cf31ffbfbbc.tar.gz
txr-7de6f85f52201269f2890903adf12cf31ffbfbbc.tar.bz2
txr-7de6f85f52201269f2890903adf12cf31ffbfbbc.zip
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.
Diffstat (limited to 'share')
-rw-r--r--share/txr/stdlib/match.tl109
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)