From 59da72099d08b1b2573cc80bcd1493033b479e0c Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Sat, 10 May 2025 19:48:30 -0700 Subject: match: make @(require) work over args in lambda-match. The issue is that in a lambda-match, when we wrap @(require) around an argument match, it becomes a single pattern which matches the variadic arguments as a list. As a result, the function also becomes variadic, and a list is consed up for the match. A nested list is worth a thousand words: Before this change: 1> (expand '(lambda-match (@(require (@a @b) (= 5 (+ a b))) (cons a b)))) (lambda (. #:rest0014) (let (#:result0015) (or (let* (a b) (let ((#:g0017 (list* #:rest0014))) (if (consp #:g0017) (let ((#:g0018 (car #:g0017)) (#:g0019 (cdr #:g0017))) (sys:setq a #:g0018) (if (consp #:g0019) (let ((#:g0020 (car #:g0019)) (#:g0021 (cdr #:g0019))) (sys:setq b #:g0020) (if (equal #:g0021 '()) (if (and (= 5 (+ a b))) (progn (sys:setq #:result0015 (cons a b)) t)))))))))) #:result0015)) After this change: 1> (expand '(lambda-match (@(require (@a @b) (= 5 (+ a b))) (cons a b)))) (lambda (#:arg-00015 #:arg-10016) (let (#:result0017) (or (let* (b a) (sys:setq b #:arg-10016) (sys:setq a #:arg-00015) (if (and (= 5 (+ a b))) (progn (sys:setq #:result0017 (cons a b)) t)))) #:result0017)) @(require (@a @b)) now leads to a two-argument function. The guard condition is applied to the a and b variables extracted from the arguments rather than a list. * stdlib/match.tl (when-exprs-match): Macro removed. (struct lambda-clause): New slot, require-conds. (parse-lambda-match-clause): Recognize @(require ...) syntax, destructure it and recurse into the argument pattern it contains. Because the incoming syntax includes the clause body, for the recursive call we synthesize syntax consisting of the pattern extracted from the @(require), coupled with the clause body. When the recursive call gives us a lambda-clause structure, we then add the require guard expressions to it. So in essence the behavior is that we parse the (@(require argpat cond ...) body) as if it were (argpat body), and decorate the object with the extracted conditions. (expand-lambda-match): This now takes an env argument due to the fact that when-exprs-match was removed. when-exprs-match relied on its :env parameter to get the environment, needed for compile-match. Now expand-lambda-match directly calls compile-match, doing all the work that when-exprs-match helper was doing. Integrating that into expand-lambda-match allows us to add logic to detect that the lambda-clause structure has require conditions, and add the code as a guard to the compiled match using add-guards-post. (lambda-match, defun-match, :match): Pass environment argument to expand-lambda-match. --- stdlib/match.tl | 72 ++++++++++++++++++++++++++++++++------------------------- 1 file 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) -- cgit v1.2.3