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.

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)