diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2021-04-24 20:26:17 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2021-04-24 20:26:17 -0700 |
| commit | 7de6f85f52201269f2890903adf12cf31ffbfbbc (patch) | |
| tree | 9040af4f0686d505823ea29eb479364922ac559b /share | |
| parent | 4e32c272c818c01577f42a63e09b01f8b6257fe4 (diff) | |
| download | txr-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.tl | 109 |
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) |