diff options
| -rw-r--r-- | stdlib/match.tl | 72 |
1 files changed, 40 insertions, 32 deletions
diff --git a/stdlib/match.tl b/stdlib/match.tl index f389d81b..674e3aa6 100644 --- a/stdlib/match.tl +++ b/stdlib/match.tl @@ -791,29 +791,30 @@ ,*(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 + require-conds (: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) + (match-case args + (@(atom) + (new lambda-clause + orig-syntax args + variadic-pattern args + forms body)) + ((@(eq 'sys:expr) (require @inargs . @conditions)) + (let ((pc (parse-lambda-match-clause ^(,inargs ,*body)))) + (set pc.require-conds (append conditions pc.require-conds)) + pc)) + (@(proper-list-p) (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 @@ -821,13 +822,14 @@ 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) + (@nil + (new lambda-clause + orig-syntax args + fixed-patterns (butlast args 0) + variadic-pattern (last args 0) + forms body))))) + +(defun expand-lambda-match (clauses env) (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)) @@ -845,15 +847,21 @@ (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))) + (em (compile-match + ^@(exprs ,*pc.fixed-patterns ,*(if vp (list vp))) + ^(,*[arg-temps 0..pc.nfixed] + ,*(if vp + ^((list* ,*[arg-temps pc.nfixed..:] + ,rest-temp)))) + (get-var-list env))) + (exp (progn + (iflet ((conds pc.require-conds)) + em.(add-guards-post (new match-guard + guard-expr ^(and ,*conds)))) + ^(let* (,*em.(get-vars)) + ,em.(wrap-guards ^(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)] @@ -874,11 +882,11 @@ (or ,*ex-clauses) ,result-temp)))) -(defmacro lambda-match (:form *match-form* . clauses) - (expand-lambda-match clauses)) +(defmacro lambda-match (:env e :form *match-form* . clauses) + (expand-lambda-match clauses e)) -(defmacro defun-match (:form *match-form* name . clauses) - (tree-bind (t args . body) (expand-lambda-match clauses) +(defmacro defun-match (:form *match-form* :env e name . clauses) + (tree-bind (t args . body) (expand-lambda-match clauses e) ^(defun ,name ,args . ,body))) (defmacro match-tuple-case (args . clauses) @@ -895,7 +903,7 @@ (compile-error form "~s is incompatible with optional parameters" :match)) - (tree-bind (t lparams . body) (expand-lambda-match clauses) + (tree-bind (t lparams . body) (expand-lambda-match clauses menv) (let ((dashdash (member '-- params))) (cons (append (ldiff params dashdash) (butlastn 0 lparams) |