;; Copyright 2021-2024 ;; Kaz Kylheku ;; Vancouver, Canada ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are met: ;; ;; 1. Redistributions of source code must retain the above copyright notice, ;; this list of conditions and the following disclaimer. ;; ;; 2. Redistributions in binary form must reproduce the above copyright notice, ;; this list of conditions and the following disclaimer in the documentation ;; and/or other materials provided with the distribution. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ;; POSSIBILITY OF SUCH DAMAGE. (defvar *match-form*) (defvar *match-macro* (hash)) (defex match-error eval-error) (defstruct match-guard () temps vars var-exprs pure-temps pure-temp-exprs (guard-expr t) (test-expr t) (:method assignments (me) (mapcar (op list 'set) me.vars me.var-exprs)) (:method lets (me) (zip me.pure-temps me.pure-temp-exprs)) (:method wrap-expr (g exp) (let ((lets g.(lets)) (temps g.temps)) (if (neq t g.test-expr) (set exp ^(if ,g.test-expr ,exp))) (cond ((and lets temps) (set exp ^(alet ,lets (let ,temps ,*g.(assignments) ,exp)))) (lets (set exp ^(alet ,lets ,*g.(assignments) ,exp))) (temps (set exp ^(let ,temps ,*g.(assignments) ,exp))) (t (set exp ^(progn ,*g.(assignments) ,exp)))) (when (neq t g.guard-expr) (set exp ^(if ,g.guard-expr ,exp))) exp))) (defstruct guard-disjunction () guard-chains sub-patterns all-vars (:method wrap-expr (g exp) (let* ((vars [mapcar get-vars g.guard-chains]) (back-vars (cons nil (reverse [mapcar (ap append) (conses (reverse vars))]))) (branches (collect-each ((gc g.guard-chains) (v vars) (bv back-vars)) ^(progn (set ,*(mappend (ret ^(,@1 nil)) (diff bv v))) ,(reduce-right (umeth wrap-expr) gc t))))) (set exp ^(when (or ,*branches) ,exp)) exp))) (defstruct compiled-match () pattern obj-var guard-chain (:method get-vars (me) (uniq (get-vars me.guard-chain))) (:method wrap-guards (me . forms) (reduce-right (umeth wrap-expr) me.guard-chain ^(progn ,*forms))) (:method add-guard-pre (me guard) (push guard me.guard-chain)) (:method add-guards-pre (me . guards) (set me.guard-chain (append guards me.guard-chain))) (:method add-guards-post (me . guards) (set me.guard-chain (append me.guard-chain guards)))) (defstruct var-list () vars menv (:method exists (me sym) (or (member sym me.vars) (lexical-binding-kind me.menv sym) (boundp sym))) (:method record (me sym) (push sym me.vars)) (:method merge (me copy) (each ((v copy.vars)) (pushnew v me.vars)))) (defun get-vars (guard-chain) (append-each ((g guard-chain)) (typecase g (match-guard g.vars) (guard-disjunction (append-each ((gc g.guard-chains)) (get-vars gc))) (t (compile-error *match-form* "internal error: bad guard ~s" g))))) (defun compile-struct-match (struct-pat obj-var var-list) (mac-param-bind *match-form* (t required-type . pairs) struct-pat (let* ((loose-p (not (bindable required-type))) (slot-pairs (plist-to-alist pairs)) (required-slots [mapcar car slot-pairs]) (slot-gensyms [mapcar gensym required-slots]) (type-gensym (if loose-p (gensym "type-"))) (slot-patterns [mapcar cdr slot-pairs]) (slot-matches [mapcar (lop compile-match var-list) slot-patterns slot-gensyms]) (type-match (if loose-p (compile-match required-type type-gensym var-list))) (slot-val-exprs [mapcar (ret ^(slot ,obj-var ',@1)) required-slots]) (guard0 (if loose-p (list (new match-guard pure-temps (list type-gensym) pure-temp-exprs (list ^(struct-type ,obj-var)) guard-expr ^(structp ,obj-var))))) (guard1 (list (new match-guard pure-temps slot-gensyms pure-temp-exprs slot-val-exprs guard-expr (if loose-p ^(and ,*(mapcar (ret ^(slotp ,type-gensym ',@1)) required-slots)) ^(typep ,obj-var ',required-type)))))) (unless loose-p (let ((type (find-struct-type required-type))) (if type (each ((slot required-slots)) (unless (slotp type slot) (compile-defr-warning *match-form* ^(slot . ,slot) "~s has no slot ~s" required-type slot))) (compile-defr-warning *match-form* ^(struct-type . ,required-type) "no such struct type: ~s" required-type)))) (new compiled-match pattern struct-pat obj-var obj-var guard-chain (append guard0 type-match.?guard-chain guard1 (mappend .guard-chain slot-matches)))))) (defun compile-var-match (sym obj-var var-list) (cond ((null sym) (new compiled-match obj-var obj-var)) ((not (bindable sym)) (compile-error *match-form* "~s is not a bindable symbol" sym)) ((not var-list.(exists sym)) var-list.(record sym) (new compiled-match pattern sym obj-var obj-var guard-chain (if sym (list (new match-guard vars (list sym) var-exprs (list obj-var)))))) (t (new compiled-match pattern sym obj-var obj-var guard-chain (list (new match-guard guard-expr ^(equal ,obj-var ,sym))))))) (defun compile-new-var-match (sym obj-var var-list) (cond ((null sym) (new compiled-match obj-var obj-var)) ((not (bindable sym)) (compile-error *match-form* "~s is not a bindable symbol" sym)) (t var-list.(record sym) (new compiled-match pattern sym obj-var obj-var guard-chain (if sym (list (new match-guard vars (list sym) var-exprs (list obj-var)))))))) (defun compile-vec-match (vec-pat obj-var var-list) (let* ((elem-gensyms (mapcar (op gensym `elem-@1-`) (range* 0 (len vec-pat)))) (elem-exprs (mapcar (ret ^[,obj-var ,@1]) (range* 0 (len vec-pat)))) (elem-matches (list-vec [mapcar (lop compile-match var-list) vec-pat elem-gensyms])) (pruned-triple (multi (op keep-if .guard-chain @1 third) elem-gensyms elem-exprs elem-matches)) (guard (new match-guard pure-temps (first pruned-triple) pure-temp-exprs (second pruned-triple) guard-expr ^(and (vectorp ,obj-var) (eql (len ,obj-var) ,(len vec-pat)))))) (new compiled-match pattern vec-pat obj-var obj-var guard-chain (cons guard (mappend .guard-chain elem-matches))))) (defun compile-range-match (range-expr obj-var var-list) (let ((from (from range-expr)) (to (to range-expr))) (let* ((from-match (compile-match from (gensym "from") var-list)) (to-match (compile-match to (gensym "to") var-list)) (guard (new match-guard guard-expr ^(rangep ,obj-var) pure-temps (list from-match.obj-var to-match.obj-var) pure-temp-exprs (list ^(from ,obj-var) ^(to ,obj-var))))) (new compiled-match pattern range-expr obj-var obj-var guard-chain (cons guard (append from-match.guard-chain to-match.guard-chain)))))) (defun compile-atom-match (atom obj-var var-list) (flet ((compile-as-atom () (new compiled-match pattern atom obj-var obj-var guard-chain (list (new match-guard guard-expr ^(equal ,obj-var ',atom)))))) (typecase atom (vec (if (non-triv-pat-p atom) (compile-vec-match atom obj-var var-list) (compile-as-atom))) (range (if (non-triv-pat-p atom) (compile-range-match atom obj-var var-list) (compile-as-atom))) (t (compile-as-atom))))) (defun compile-predicate-match (exp obj-var var-list) (let ((head (car exp))) (if (and (consp head) (eq (car head) 'sys:var)) (tree-case exp (((t rvar) (op . args)) (let* ((arg-var (gensym "obj-")) (avar (condlet (((vm (member-if [andf consp (op eq (car @1) 'sys:var)] args))) (let ((sym (cadar vm))) (if (null sym) (set sym arg-var) (set arg-var sym)) (set args (append (ldiff args vm) (list sym) (cdr vm))) sym)) (((vm (memq 'sys:var args))) (let ((sym (cadr vm))) (if (null sym) (set sym arg-var) (set arg-var sym)) (set args (append (ldiff args vm) sym)) sym)))) (res-var (gensym "res-"))) (unless avar (set args (append args (list arg-var)))) (let* ((guard (new match-guard pure-temps (list res-var) pure-temp-exprs ^((alet ((,arg-var ,obj-var)) (,op ,*args))) test-expr res-var)) (avar-match (compile-var-match avar obj-var var-list)) (rvar-match (compile-var-match rvar res-var var-list))) (new compiled-match pattern exp obj-var obj-var guard-chain (append avar-match.guard-chain (list guard) rvar-match.guard-chain))))) (else (compile-error *match-form* "invalid predicate syntax: ~s" else))) (compile-predicate-match (list '@nil exp) obj-var var-list)))) (defun compile-cons-structure (cons-pat obj-var var-list) (mac-param-bind *match-form* (car . cdr) cons-pat (let* ((car-gensym (gensym)) (cdr-gensym (gensym)) (car-match (compile-match car car-gensym var-list)) (cdr-match (if (consp cdr) (caseq (car cdr) ((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 pure-temps (append (if car-match.guard-chain (list car-gensym)) (if cdr-match.guard-chain (list cdr-gensym))) pure-temp-exprs (append (if car-match.guard-chain ^((car ,obj-var))) (if cdr-match.guard-chain ^((cdr ,obj-var)))) guard-expr ^(consp ,obj-var)))) (new compiled-match pattern cons-pat obj-var obj-var guard-chain (cons guard (append car-match.guard-chain cdr-match.guard-chain)))))) (defun compile-require-match (exp obj-var var-list) (mac-param-bind *match-form* (t match . conditions) exp (let ((match (compile-match match obj-var var-list))) match.(add-guards-post (new match-guard guard-expr ^(and ,*conditions))) match))) (defun compile-as-match (exp obj-var var-list) (mac-param-bind *match-form* (t sym pat) exp (let ((var-match (compile-new-var-match sym obj-var var-list)) (pat-match (compile-match pat obj-var var-list))) (new compiled-match pattern exp obj-var obj-var guard-chain (append var-match.guard-chain pat-match.guard-chain))))) (defun compile-with-match (exp obj-var var-list) (tree-case exp ((t main-pat side-pat-var side-expr) (let* ((side-var (gensym)) (side-pat (if (or (null side-pat-var) (bindable side-pat-var)) ^(sys:var ,side-pat-var) side-pat-var)) (main-match (compile-match main-pat obj-var var-list)) (side-match (compile-match side-pat side-var var-list)) (guard (new match-guard pure-temps (list side-var) pure-temp-exprs (list side-expr)))) (new compiled-match pattern exp obj-var obj-var guard-chain (append main-match.guard-chain (list guard) side-match.guard-chain)))) ((op side-pat-var side-expr) (compile-with-match ^(,op @nil ,side-pat-var ,side-expr) obj-var var-list)) (else (compile-error *match-form* "bad syntax: ~s" else)))) (defun compile-loop-match (exp obj-var var-list) (mac-param-bind *match-form* (op match) exp (let* ((no-vac-p (memq op '(coll usr:all*))) (some-p (eq op 'some)) (coll-p (eq op 'coll)) (item-var (gensym "item-")) (in-vars var-list.vars) (cm (compile-match match item-var var-list)) (loop-success-p-var (gensym "loop-success-p-")) (loop-continue-p-var (gensym "loop-terminate-p")) (loop-iterated-var (if no-vac-p (gensym "loop-iterated-p"))) (matched-p-var (gensym "matched-p-")) (iter-var (gensym "iter-")) (cm-vars cm.(get-vars)) (collect-vars (diff cm-vars in-vars)) (collect-gens [mapcar gensym collect-vars]) (loop ^(for ((,iter-var (iter-begin ,obj-var)) (,loop-continue-p-var t) ,*(if no-vac-p ^((,loop-iterated-var nil)))) ((and ,loop-continue-p-var (iter-more ,iter-var)) ,(cond (some-p ^(not ,loop-continue-p-var)) (no-vac-p ^(and ,loop-iterated-var ,loop-continue-p-var)) (t loop-continue-p-var))) ((set ,iter-var (iter-step ,iter-var))) (let ((,cm.obj-var (iter-item ,iter-var)) ,matched-p-var ,*(unless some-p cm-vars)) ,cm.(wrap-guards ^(progn (set ,matched-p-var t) ,*(if no-vac-p ^((set ,loop-iterated-var t))) ,*(unless some-p (mapcar (ret ^(push ,@1 ,@2)) collect-vars collect-gens)))) ,(unless coll-p ^(,(if some-p 'when 'unless) ,matched-p-var (set ,loop-continue-p-var nil)))))) (guard0 (new match-guard vars cm-vars temps (unless some-p collect-gens) guard-expr ^(seqp ,obj-var))) (guard1 (new match-guard vars (list loop-success-p-var) var-exprs (list loop) test-expr (if some-p loop-success-p-var ^(when ,loop-success-p-var ,*(mapcar (ret ^(set ,@1 (nreverse ,@2))) collect-vars collect-gens) t))))) (new compiled-match pattern exp obj-var obj-var guard-chain (list guard0 guard1))))) (defun compile-or-match (par-pat obj-var var-list) (mac-param-bind *match-form* (t . pats) par-pat (let* ((var-lists (mapcar (ret (copy var-list)) pats)) (par-matches (mapcar (op compile-match @1 obj-var @2) pats var-lists)) (dj-guard (new guard-disjunction guard-chains (mapcar .guard-chain par-matches) sub-patterns par-matches))) (each ((vl var-lists)) var-list.(merge vl)) (new compiled-match pattern par-pat obj-var obj-var guard-chain (list dj-guard))))) (defun compile-and-match (and-pat obj-var var-list) (mac-param-bind *match-form* (t . pats) and-pat (let* ((par-matches (mapcar (lop compile-match obj-var var-list) pats))) (new compiled-match pattern and-pat obj-var obj-var guard-chain (mappend .guard-chain par-matches))))) (defun compile-not-match (pattern obj-var var-list) (mac-param-bind *match-form* (t pattern) pattern (let* ((pm (compile-match pattern obj-var var-list)) (guard (new match-guard guard-expr ^(not (let ,pm.(get-vars) ,pm.(wrap-guards t)))))) (new compiled-match pattern pattern obj-var obj-var guard-chain (list guard))))) (defun compile-hash-match (hash-expr obj-var var-list) (mac-param-bind *match-form* (t . pairs) hash-expr (let* ((hash-alist-var (gensym "hash-alist-")) (hash-alt-val ^',(gensym "alt")) (need-alist-p nil) (hash-keys-var (gensym "hash-keys-")) (need-keys-p nil) (hash-matches (collect-each ((pair pairs)) (mac-param-bind *match-form* (key : (val nil val-p)) pair (let ((key-pat-p (non-triv-pat-p key)) (val-pat-p (non-triv-pat-p val)) (key-var-sym (var-pat-p key))) (cond ((and (not val-p) key-var-sym var-list.(exists key-var-sym)) (let ((guard (new match-guard test-expr ^(inhash ,obj-var ,key-var-sym)))) (new compiled-match guard-chain (list guard)))) ((and (not val-p) (not key-pat-p)) (let ((guard (new match-guard test-expr ^(inhash ,obj-var ',key)))) (new compiled-match guard-chain (list guard)))) ((not val-p) (set need-keys-p t) (compile-match key hash-keys-var var-list)) ((and key-var-sym var-list.(exists key-var-sym)) (let ((vm (compile-match val (gensym "val") var-list))) vm.(add-guards-pre (new match-guard vars (list vm.obj-var) var-exprs ^((gethash ,obj-var ,key-var-sym ,hash-alt-val)) test-expr ^(neq ,vm.obj-var ,hash-alt-val))) vm)) ((and key-pat-p val-pat-p) (set need-alist-p t) (compile-match ^@(coll (,key . ,val)) hash-alist-var var-list)) (key-pat-p (let ((km (compile-match key (gensym "keys") var-list))) km.(add-guards-pre (new match-guard pure-temps (list km.obj-var) pure-temp-exprs ^((hash-keys-of ,obj-var ',val)))) km)) (t (let ((vm (compile-match val (gensym "val") var-list))) vm.(add-guards-pre (new match-guard pure-temps (list vm.obj-var) pure-temp-exprs ^((gethash ,obj-var ',key ,hash-alt-val)) test-expr ^(neq ,vm.obj-var ,hash-alt-val))) vm))))))) (guard (new match-guard guard-expr ^(hashp ,obj-var) vars (append (if need-alist-p (list hash-alist-var)) (if need-keys-p (list hash-keys-var))) var-exprs (append (if need-alist-p (list ^(hash-alist ,obj-var))) (if need-keys-p (list ^(hash-keys ,obj-var))))))) (new compiled-match pattern hash-expr obj-var obj-var guard-chain (cons guard (mappend .guard-chain hash-matches)))))) (defun compile-scan-match (scan-syntax obj-var var-list) (mac-param-bind *match-form* (t pattern) scan-syntax (with-gensyms (iter found-p cont-p success-p) (let* ((cm (compile-match pattern iter var-list)) (loop ^(for ((,iter ,obj-var) (,cont-p t) ,found-p) (,cont-p ,found-p) ((cond ((null ,cont-p)) ((consp ,iter) (set ,iter (cdr ,iter))) (t (zap ,cont-p)))) ,cm.(wrap-guards ^(set ,found-p t ,cont-p nil)))) (guard (new match-guard vars (cons success-p cm.(get-vars)) var-exprs (list loop) test-expr success-p))) (new compiled-match pattern scan-syntax obj-var obj-var guard-chain (list guard)))))) (defun compile-scan-all-match (scan-syntax obj-var var-list) (mac-param-bind *match-form* (t pattern) scan-syntax (with-gensyms (iter) (let* ((in-vars var-list.vars) (cm (compile-match pattern iter var-list)) (cm-vars cm.(get-vars)) (collect-vars (diff cm-vars in-vars)) (collect-gens [mapcar gensym collect-vars]) (loop ^(for ((,iter ,obj-var)) (,iter t) ((set ,iter (cdr ,iter))) ,cm.(wrap-guards ^(progn ,*(mapcar (ret ^(push ,@1 ,@2)) collect-vars collect-gens))))) (guard (new match-guard vars cm-vars temps collect-gens test-expr ^(progn ,loop ,*(mapcar (ret ^(set ,@1 (nreverse ,@2))) collect-vars collect-gens))))) (new compiled-match pattern scan-syntax obj-var obj-var guard-chain (list guard)))))) (defun compile-exprs-match (exprs-syntax uexprs var-list) (let ((upats (cdr exprs-syntax)) (utemps (mapcar (ret (gensym)) uexprs))) (tree-bind (pats temps t) (multi-sort (list upats utemps uexprs) [list less] [list non-triv-pat-p]) (let* ((matches (mapcar (op compile-match @1 @2 var-list) pats temps))) (new compiled-match pattern exprs-syntax obj-var nil guard-chain (cons (new match-guard pure-temps utemps pure-temp-exprs uexprs) (mappend .guard-chain matches))))))) (defun compile-match (pat : (obj-var (gensym)) (var-list (new var-list))) (cond ((consp pat) (caseq (car pat) (sys:expr (let ((exp (cadr pat))) (if (consp exp) (let ((op (car exp))) (caseq op (struct (compile-struct-match exp obj-var var-list)) (require (compile-require-match exp obj-var var-list)) (usr:as (compile-as-match exp obj-var var-list)) (usr:with (compile-with-match exp obj-var var-list)) (all (compile-loop-match exp obj-var var-list)) (usr:all* (compile-loop-match exp obj-var var-list)) (some (compile-loop-match exp obj-var var-list)) (coll (compile-loop-match exp obj-var var-list)) (or (compile-or-match exp obj-var var-list)) (and (compile-and-match exp obj-var var-list)) (not (compile-not-match exp obj-var var-list)) (hash (compile-hash-match exp obj-var var-list)) (usr:scan (compile-scan-match exp obj-var var-list)) (usr:scan-all (compile-scan-all-match exp obj-var var-list)) (exprs (compile-exprs-match exp obj-var var-list)) (sys:quasi (compile-match exp obj-var var-list)) (t (iflet ((xfun [*match-macro* op])) (let* ((var-env (make-env (mapcar (lop cons 'sys:special) var-list.vars) nil var-list.menv)) (xexp [xfun exp var-env])) (if (neq xexp exp) (compile-match xexp obj-var var-list) (compile-predicate-match exp obj-var var-list))) (compile-predicate-match exp obj-var var-list))))) (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)) (sys:qquote (compile-match (transform-qquote (cadr pat)) 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))))) (t (compile-atom-match pat obj-var var-list)))) (defun get-var-list (env) (new var-list menv env)) (defmacro when-match (:form *match-form* :env e pat obj . body) (let ((cm (compile-match pat : (get-var-list e)))) ^(alet ((,cm.obj-var ,obj)) (let ,cm.(get-vars) ,cm.(wrap-guards . body))))) (defmacro if-match (:form *match-form* :env e pat obj then : else) (let ((cm (compile-match pat : (get-var-list e))) (result (gensym "result-"))) ^(alet ((,cm.obj-var ,obj)) (let* (,result ,*cm.(get-vars)) (if ,cm.(wrap-guards ^(set ,result ,then) t) ,result ,else))))) (defun match-pat-error (sym pat val) (throwf 'match-error "~s: ~s failed to match object ~s" sym pat val)) (defun match-error (sym val) (throwf 'match-error "~s: failed to match object ~s" sym val)) (defmacro match (pat obj . body) (with-gensyms (val) ^(let ((,val ,obj)) (if-match ,pat ,val (progn ,*body) (match-pat-error 'match ',pat ,val))))) (defmacro while-match (:form *match-form* :env e pat obj . body) (let ((cm (compile-match pat : (get-var-list e)))) ^(for () ((alet ((,cm.obj-var ,obj)) (let ,cm.(get-vars) ,cm.(wrap-guards ^(progn ,*body t))))) ()))) (defun non-triv-pat-p (syntax) (ignore syntax) t) (defun match-case-to-casequal (obj clauses) (let ((dfl-cnt 0)) (if (and [all clauses [chain car [orf [chain non-triv-pat-p not] [iff (op equal '@nil) (do inc dfl-cnt)] (do if-match (@(eq 'sys:var) @nil) @1 (inc dfl-cnt))]]] (< dfl-cnt 2) (or (zerop dfl-cnt) (non-triv-pat-p (car (first (last clauses)))))) (with-gensyms (otmp) ^(let ((,otmp ,obj)) (casequal ,otmp ,*(mapcar (tb ((f . r)) (or (if-match (@(eq 'sys:var) nil) f ^(t ,*r)) (if-match (@(eq 'sys:var) @sym) f ^(t (let ((,sym ,otmp)) ,*r))) ^((,f) ,*r))) clauses))))))) (defmacro match-case (:form *match-form* :env e obj . clauses) (unless [all clauses [andf proper-listp [chain len plusp]]] (compile-error *match-form* "bad clause syntax")) (iflet ((cq (match-case-to-casequal obj clauses))) cq (let* ((result-temp (gensym "result-")) (objvar (gensym "obj-")) (var-list (get-var-list e)) (clause-matches [mapcar (op compile-match (car @1) objvar (copy var-list)) clauses]) (clause-code (collect-each ((cl clauses) (cm clause-matches)) (mac-param-bind *match-form* (t . forms) cl ^(let (,*cm.(get-vars)) ,cm.(wrap-guards ^(set ,result-temp (progn ,*forms)) t)))))) ^(alet ((,objvar ,obj)) (let (,result-temp) (or ,*clause-code) ,result-temp))))) (defmacro match-cond (:form *match-form* :env e . clauses) (unless [all clauses [andf proper-listp [chain len (op < 1)]]] (compile-error *match-form* "bad clause syntax")) (let* ((result-temp (gensym "result-")) (var-list (get-var-list e)) (clause-matches [mapcar (op compile-match (car @1) : (copy var-list)) clauses]) (clause-code (collect-each ((cl clauses) (cm clause-matches)) (mac-param-bind *match-form* (t obj . forms) cl ^(let (,*cm.(get-vars) (,cm.obj-var ,obj)) ,cm.(wrap-guards ^(set ,result-temp (progn ,cm.obj-var ,*forms)) t)))))) ^(let (,result-temp) (or ,*clause-code) ,result-temp))) (defmacro match-ecase (obj . clauses) (with-gensyms (else) ^(match-case ,obj ,*clauses ((var ,else) (match-error 'match-ecase ,else))))) (defmacro while-match-case (:form *match-form* obj . clauses) (unless [all clauses [andf proper-listp [chain len plusp]]] (compile-error *match-form* "bad clause syntax")) ^(for () ((match-case ,obj ,*(mapcar (ret ^(,(car @1) ,*(cdr @1) t)) clauses))) ())) (defmacro while-true-match-case (:form *match-form* obj . clauses) (unless [all clauses [andf proper-listp [chain len plusp]]] (compile-error *match-form* "bad clause syntax")) ^(for () ((match-case ,obj (nil) ,*(mapcar (ret ^(,(car @1) ,*(cdr @1) t)) clauses))) ())) (defmacro when-exprs-match (:form *match-form* :env e pats exprs . forms) (let ((em (compile-match ^@(exprs ,*pats) exprs (get-var-list e)))) ^(let* (,*em.(get-vars)) ,em.(wrap-guards . forms)))) (defstruct lambda-clause () orig-syntax fixed-patterns variadic-pattern nfixed forms (:postinit (me) (set me.nfixed (len me.fixed-patterns)))) (defun parse-lambda-match-clause (clause) (mac-param-bind *match-form* (args . body) clause (cond ((atom args) (new lambda-clause orig-syntax args variadic-pattern args forms body)) ((proper-list-p 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 fixed-patterns fixed-pats variadic-pattern (car variadic-pat) forms body)))) (t (new lambda-clause orig-syntax args fixed-patterns (butlast args 0) variadic-pattern (last args 0) forms body))))) (defun expand-lambda-match (clauses) (let* ((parsed-clauses [mapcar parse-lambda-match-clause clauses]) (max-args (or [find-max parsed-clauses : .nfixed].?nfixed 0)) (min-args (or [find-min parsed-clauses : .nfixed].?nfixed 0)) (variadic [some parsed-clauses .variadic-pattern]) (fix-arg-temps (mapcar (op gensym `arg-@1`) (range* 0 min-args))) (opt-arg-temps (mapcar (op gensym `arg-@1`) (range* min-args max-args))) (rest-temp (if variadic (gensym `rest`))) (present-p-temps (mapcar (op gensym `have-@1`) (range* min-args max-args))) (arg-temps (append fix-arg-temps opt-arg-temps)) (present-vec (vec-list (append (repeat '(t) min-args) present-p-temps))) (result-temp (gensym "result")) (ex-clauses (collect-each ((pc parsed-clauses)) (let* ((vp pc.variadic-pattern) (exp ^(when-exprs-match (,*pc.fixed-patterns ,*(if vp (list vp))) (,*[arg-temps 0..pc.nfixed] ,*(if vp ^((list* ,*[arg-temps pc.nfixed..:] ,rest-temp)))) (set ,result-temp (progn ,*pc.forms)) t))) (sys:set-macro-ancestor exp pc.orig-syntax) (when (> pc.nfixed min-args) (set exp ^(when ,[present-vec (pred pc.nfixed)] ,exp))) (when (and (not vp) (< pc.nfixed max-args)) (set exp ^(unless ,[present-vec pc.nfixed] ,exp))) (when (and variadic (not vp) (= pc.nfixed max-args)) (set exp ^(unless ,rest-temp ,exp))) exp)))) ^(lambda (,*fix-arg-temps ,*(if opt-arg-temps (cons : (mapcar (ret ^(,@1 nil ,@2)) opt-arg-temps present-p-temps))) . ,rest-temp) (let (,result-temp) (or ,*ex-clauses) ,result-temp)))) (defmacro lambda-match (:form *match-form* . clauses) (expand-lambda-match clauses)) (defmacro defun-match (:form *match-form* name . clauses) (tree-bind (t args . body) (expand-lambda-match clauses) ^(defun ,name ,args . ,body))) (define-param-expander :match (params clauses menv form) (ignore menv) (let ((*match-form* form)) (unless (proper-list-p params) (compile-error form "~s is incompatible with dotted parameter lists" :match)) (when (find : params) (compile-error form "~s is incompatible with optional parameters" :match)) (tree-bind (t lparams . body) (expand-lambda-match clauses) (let ((dashdash (member '-- params))) (cons (append (ldiff params dashdash) (butlastn 0 lparams) dashdash (nthlast 0 lparams)) body))))) (defmacro defmatch (name destructuring-args . body) (with-gensyms (name-dummy args vars-env) ^(progn (sethash *match-macro* ',name (lambda (,args ,vars-env) (mac-env-param-bind *match-form* ,vars-env (,name-dummy ,*destructuring-args) ,args ,*body))) ',name))) (defun macroexpand-match (pattern : env) (iflet ((xfun (and (consp pattern) [*match-macro* (car pattern)]))) [xfun pattern env] pattern)) (defun check (f op pat) (if (or (not (listp pat)) (meq (car pat) 'sys:expr 'sys:var 'sys:quasi)) (compile-error f "~s: list pattern expected, not ~s" op pat) pat)) (defun check-sym (f op sym : nil-ok) (cond ((bindable sym) sym) ((and (null sym) nil-ok) sym) (t (compile-error f "~s: bindable symbol expected, not ~s" op sym)))) (defun loosen (pat) (if (proper-list-p pat) (append pat '@nil) pat)) (defun pat-len (pat) (if (consp pat) (let ((var-op-pos (pos-if (lop meq 'sys:var 'sys:expr 'sys:quasi) (butlastn 0 pat)))) (if var-op-pos var-op-pos (len pat))) 0)) (defmatch sme (:form f sta mid end : (mvar (gensym)) eobj) (let* ((psta (loosen (check f 'sme sta))) (pmid (loosen (check f 'sme mid))) (lsta (pat-len psta)) (lmid (pat-len pmid)) (lend (pat-len end)) (obj (gensym))) ^@(as ,(check-sym f 'sme obj) @(and ,psta @(with @(scan @(as ,(check-sym f 'sme mvar) ,pmid)) (nthcdr ,lsta ,obj)) @(with @(as ,(check-sym f 'sme eobj t) ,end) (nthlast ,lend (nthcdr ,lmid ,mvar))))))) (defmatch end (:form f end : evar) (let* ((lend (pat-len end)) (obj (gensym))) ^@(as ,(check-sym f 'end obj) @(with @(as ,(check-sym f 'end evar t) ,end) (nthlast ,lend ,obj))))) (defun non-triv-pat-p (syntax) (match-case syntax ((@(eq 'sys:expr) (@(bindable) . @nil)) t) ((@(eq 'sys:var) @(or @(bindable) nil) . @nil) t) ((@(eq 'sys:quasi) . @(some @(consp))) t) ((@(eq 'sys:qquote) @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) vlist.(exists sym))) ((null sym) nil) ((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 (vlist args vars str pos) (match-case args ;; `text` ((@(stringp @txt)) (list ^@(require @nil (eql (len ,str) (match-str ,str ,txt ,pos))))) ;; `txt@...` ((@(stringp @txt) . @rest) (with-gensyms (npos) (cons ^@(require @(with ,npos (+ ,pos (len ,txt))) (match-str ,str ,txt ,pos)) (quasi-match vlist rest vars str npos)))) ;; `@{var #/rx/}` (existing binding) (((@(eq 'sys:var) @(bound-p vlist vars @sym) (@(regexp @reg)))) (list ^@(require @nil (equal ,sym (m^$ ,reg (sub-str ,str ,pos t)))))) ;; `@{var #/rx/}@...` (existing binding) (((@(eq 'sys:var) @(bound-p vlist vars @sym) (@(regexp @reg))) . @rest) (with-gensyms (len npos) (list* ^@(require @(with ,len (match-regex ,str ,reg ,pos)) ,len) ^@(with ,npos (+ ,pos ,len)) ^@(require @nil (equal ,sym (sub-str ,str ,pos ,npos))) (quasi-match vlist rest vars str npos)))) ;; `@var` (existing binding) (((@(eq 'sys:var) @(bound-p vlist vars) . @nil)) (list ^@(require @nil (eql (len ,str) (match-str ,str (sys:quasi ,(car args)) ,pos))))) ;; `@var@...` (existing binding) ((@(as avar (@(eq 'sys:var) @(bound-p vlist vars) . @nil)) . @rest) (with-gensyms (txt len npos) (list* ^@(with ,txt (sys:quasi ,avar)) ^@(with ,len (len ,txt)) ^@(with ,npos (+ ,pos ,len)) ^@(require @nil (match-str ,str ,txt ,pos)) (quasi-match vlist rest 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)))) (if sym (list ^@(require @(with ,sym (sub-str ,str ,pos t)) (m^$ ,reg ,sym))) (list ^@(require @nil (m^$ ,reg (sub-str ,str ,pos t)))))) ;; `@{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 vlist rest (cons sym vars) str npos)))) ;; `@{var 123}` (new binding) (((@(eq 'sys:var) @sym (@(integerp @len)))) (unless (plusp len) (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))) ^@(with ,sym (sub-str ,str ,pos t))))) ;; `@{var 123}@...`` (new binding) (((@(eq 'sys:var) @sym (@(integerp @len))) . @rest) (unless (plusp len) (compile-error *match-form* "variable ~s: positive integer required,\ \ not ~a" sym len)) (with-gensyms (npos) (list* ^@(require @(with ,npos (+ ,pos ,len)) (<= ,npos (len ,str))) ^@(with ,sym (sub-str ,str ,pos ,npos)) (quasi-match vlist rest (cons sym vars) str npos)))) ;; `@{var}txt` (new binding) (((@(eq 'sys:var) @sym) @(stringp @txt)) (with-gensyms (end) (list ^@(require @(with ,end (search-str ,str ,txt ,pos)) ,end (eql (+ ,end ,(len txt)) (len ,str))) ^@(with ,sym (sub-str ,str ,pos ,end))))) ;; `@{var}txt...` (new binding) (((@(eq 'sys:var) @sym) @(stringp @txt) . @rest) (with-gensyms (end npos) (list* ^@(require @(with ,end (search-str ,str ,txt ,pos)) ,end) ^@(with ,npos (+ ,end ,(len txt))) ^@(with ,sym (sub-str ,str ,pos ,end)) (quasi-match vlist rest (cons sym vars) str npos)))) ;; `@var0@var1` (unbound followed by bound) (((@(eq 'sys:var) @sym) @(as bvar (@(eq 'sys:var) @(bound-p vlist vars) . @mods))) (ignore mods) (with-gensyms (txt end) (list ^@(with ,txt (sys:quasi ,bvar)) ^@(require @(with ,end (search-str ,str ,txt ,pos)) ,end (eql (+ , end (len ,txt)) (len ,str))) ^@(with ,sym (sub-str ,str ,pos ,end))))) ;; `@var0@var1...` (unbound followed by bound) (((@(eq 'sys:var) @sym) @(as bvar (@(eq 'sys:var) @(bound-p vlist vars) . @mods)) . @rest) (ignore mods) (with-gensyms (txt end npos) (list* ^@(with ,txt (sys:quasi ,bvar)) ^@(require @(with ,end (search-str ,str ,txt ,pos)) ,end) ^@(with ,npos (+ ,end (len ,txt))) ^@(with ,sym (sub-str ,str ,pos ,end)) (quasi-match vlist rest (cons sym vars) str npos)))) ;; `@{var whatever}@...`(new binding, unsupported modifiers) (((@(eq 'sys:var) @sym @mods . @nil) . @nil) (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 . @nil) . @nil) (compile-error *match-form* "consecutive unbound variables ~s and ~s" sym0 sym1)) ((@bad . @nil) (compile-error *match-form* "unsupported syntax ~s" ^(sys:quasi ,bad))) (@nil (compile-error *match-form* "bad quasiliteral syntax"))))) (with-gensyms (str pos) ^@(and @(require (sys:var ,str) (stringp ,str)) @(with ,pos 0) ,*(quasi-match var-list (normalize args) nil str pos))))) (defun transform-qquote (syn) (match-case syn ((sys:hash-lit nil . @(all (@key @val))) ^@(hash ,*(zip [mapcar transform-qquote key] [mapcar transform-qquote val]))) ((sys:hash-lit . @(eq nil)) '@(hash)) ((sys:struct-lit @type . @args) ^@(struct ,(transform-qquote type) ,*[mapcar transform-qquote args])) ((sys:vector-lit @elems) ^#(,*[mapcar transform-qquote elems])) ((json quote @arg) (transform-qquote arg)) ((sys:unquote @pat) (if (symbolp pat) ^(sys:var ,pat) ^(sys:expr ,pat))) ((sys:hash-lit @(have) . @nil) (compile-error *match-form* "only equal hash tables supported")) ((@(or sys:qquote) . @nil) (compile-error *match-form* "pattern-matching quasiquote doesn't support nesting")) ((sys:splice . @nil) (compile-error *match-form* "pattern-matching quasiquote doesn't support splicing")) ((@ca . @cd) (cons (transform-qquote ca) (transform-qquote cd))) (@else else))) (defun each-match-expander (f pat-seq-list body fun) (unless (and (proper-list-p pat-seq-list) (evenp (len pat-seq-list))) (compile-error f "pattern-sequence arguments must form pairs")) (let ((pat-seq-pairs (tuples 2 pat-seq-list))) (each ((pair pat-seq-pairs)) (unless (and (proper-list-p pair) (eql 2 (length pair))) (compile-error f "invalid pattern-sequence pair ~s" pair))) (let* ((pats [mapcar car pat-seq-pairs]) (seqs [mapcar cadr pat-seq-pairs]) (gens [mapcar (ret (gensym)) pat-seq-pairs])) ^(let ,(zip gens seqs) (block nil (,fun (lambda-match ((,*pats) (progn ,*body))) ,*gens)))))) (defmacro each-match (:form f pat-seq-pairs . body) (each-match-expander f pat-seq-pairs body 'mapdo)) (defmacro append-matches (:form f pat-seq-pairs . body) (each-match-expander f pat-seq-pairs body 'mappend)) (defmacro keep-matches (:form f pat-seq-pairs . body) (each-match-expander f pat-seq-pairs ^((list (progn ,*body))) 'mappend)) (defmacro each-match-product (:form f pat-seq-pairs . body) (each-match-expander f pat-seq-pairs body 'maprodo)) (defmacro append-match-products (:form f pat-seq-pairs . body) (each-match-expander f pat-seq-pairs body 'maprend)) (defmacro keep-match-products (:form f pat-seq-pairs . body) (each-match-expander f pat-seq-pairs ^((list (progn ,*body))) 'maprend))