diff options
| -rw-r--r-- | share/txr/stdlib/match.tl | 80 |
1 files changed, 44 insertions, 36 deletions
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl index f6d57e1e..ffb09e1c 100644 --- a/share/txr/stdlib/match.tl +++ b/share/txr/stdlib/match.tl @@ -592,6 +592,8 @@ (compile-error *match-form* "unrecognized pattern syntax ~s" pat)))) (sys:var (compile-var-match (cadr pat) obj-var var-list)) + (sys:quasi (compile-match (expand-quasi-match (cdr pat) var-list) + obj-var var-list)) (t (if (non-triv-pat-p pat) (compile-cons-structure pat obj-var var-list) (compile-atom-match pat obj-var var-list))))) @@ -813,18 +815,35 @@ @(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) +(defun non-triv-pat-p (syntax) t) + +(defun non-triv-pat-p (syntax) + (match-case syntax + ((@(eq 'sys:expr) (@(bindable) . @nil)) t) + ((@(eq 'sys:var) @(or @(bindable) nil) . @nil) t) + ((@pat . @rest) (or (non-triv-pat-p pat) + (non-triv-pat-p rest))) + (#R(@from @to) (or (non-triv-pat-p from) + (non-triv-pat-p to))) + (@(some @(non-triv-pat-p)) t))) + +(defun var-pat-p (syntax) + (when-match (@(eq 'sys:var) @(bindable @sym) . @nil) syntax + sym)) + +(defun expand-quasi-match (args var-list) + (labels ((bound-p (vlist vars sym) (cond - ((bindable sym) (or (member sym vars) (lexical-var-p env sym))) + ((bindable sym) (or (member sym vars) vlist.(exists sym))) ((null sym) t) - ((compile-error f "bindable symbol expected, not ~s" sym)))) + ((compile-error *match-form* "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) + (quasi-match (vlist args vars str pos) (match-case args ;; `text` ((@(stringp @txt)) @@ -834,20 +853,20 @@ (with-gensyms (npos) (cons ^@(require @(with ,npos ,(len txt)) (starts-with ,txt ,str)) - (quasi-match env rest vars str npos)))) + (quasi-match vlist rest vars str npos)))) ;; `@var` (existing binding) - (((@(eq 'sys:var) @(bound-p env vars @sym) . @nil)) + (((@(eq 'sys:var) @(bound-p vlist 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) + (((@(eq 'sys:var) @(bound-p vlist 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)))) + (quasi-match vlist (cdr args) vars str npos)))) ;; `@var` (new binding) (((@(eq 'sys:var) @sym)) (list ^@(with ,sym (sub-str ,str ,pos t)))) @@ -862,12 +881,13 @@ ,len) ^@(with ,npos (+ ,pos ,len)) ^@(with ,sym (sub-str ,str ,pos ,npos)) - (quasi-match env rest (cons sym vars) str npos)))) + (quasi-match vlist 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)) + (compile-error *match-form* + "variable ~s: positive integer required,\ \ + not ~a" sym)) (with-gensyms (npos) (list ^@(require @(with ,npos (+ ,pos ,len)) (eql ,npos (len ,str))) @@ -875,13 +895,14 @@ ;; `@{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)) + (compile-error *match-form* + "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)))) + (quasi-match vlist rest (cons sym vars) str npos)))) ;; `@{var}txt` (new binding) (((@(eq 'sys:var) @sym) @(stringp @txt) . @rest) (with-gensyms (len end npos) @@ -890,11 +911,11 @@ ^@(with ,end (+ ,pos ,len)) ^@(with ,npos (+ ,end ,(len txt))) ^@(with ,sym (sub-str ,str ,pos ,end)) - (quasi-match env (cdr rest) (cons sym vars) + (quasi-match vlist (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) + (@(eq 'sys:var) @(bound-p vlist vars @bsym) . @mods) . @rest) (with-gensyms (txt len end npos) (list* ^@(with ,txt (sys:quasi ,(cadr args))) @@ -903,37 +924,24 @@ ^@(with ,end (+ ,pos ,len)) ^@(with ,npos (+ ,end (len ,txt))) ^@(with ,sym (sub-str ,str ,pos ,end)) - (quasi-match env (cdr rest) (cons sym vars) + (quasi-match vlist (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" + (compile-error *match-form* + "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" + (compile-error *match-form* + "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))))) + ,*(quasi-match var-list (normalize args) nil str pos))))) -(defun non-triv-pat-p (syntax) t) - -(defun non-triv-pat-p (syntax) - (match-case syntax - ((@(eq 'sys:expr) (@(bindable) . @nil)) t) - ((@(eq 'sys:var) @(or @(bindable) nil) . @nil) t) - ((@pat . @rest) (or (non-triv-pat-p pat) - (non-triv-pat-p rest))) - (#R(@from @to) (or (non-triv-pat-p from) - (non-triv-pat-p to))) - (@(some @(non-triv-pat-p)) t))) - -(defun var-pat-p (syntax) - (when-match (@(eq 'sys:var) @(bindable @sym) . @nil) syntax - sym)) |