matcher: lambda-match: error diagnostics.

* share/txr/stdlib/match.tl (when-exprs-match): Bind
the *match-form* special to macro form.
(lambda-match, defun-match, :match): Likewise.
(expand-lambda-match): Set the macro ancestor for the
when-exprs-match form to the be clause syntax it was derived
from.

1 files changed, 20 insertions, 14 deletions

diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index ef707d80..f68a542e 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -585,7 +585,7 @@
          ,*clause-code
          ,result))))
 
-(defmacro when-exprs-match (pats exprs . forms)
+(defmacro when-exprs-match (:form *match-form* pats exprs . forms)
   (let ((em (compile-match ^@(exprs ,*pats) exprs)))
     ^(let* (,*em.(get-vars))
        ,em.(wrap-guards . forms))))
@@ -650,6 +650,7 @@
                                                      ,rest-temp))))
                                       (set ,matched-p-temp t)
                                       (set ,result-temp (progn ,*pc.forms)))))
+                         (sys:set-macro-ancestor exp pc.orig-syntax)
                          (when (> pc.nfixed min-args)
                            (set exp ^(when ,[present-vec (pred pc.nfixed)]
                                         ,exp)))
@@ -671,25 +672,30 @@
          ,*ex-clauses
          ,result-temp))))
 
-(defmacro lambda-match (. clauses)
+(defmacro lambda-match (:form *match-form* . clauses)
   (expand-lambda-match clauses))
 
-(defmacro defun-match (name . clauses)
+(defmacro defun-match (:form *match-form* name . clauses)
   (tree-bind (lambda args . body) (expand-lambda-match clauses)
     ^(defun ,name ,args . ,body)))
 
 (define-param-expander :match (params clauses menv 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 (lambda lparams . body) (expand-lambda-match clauses)
-    (let ((dashdash (member '-- params)))
-      (cons (append (ldiff params dashdash)
-                    (butlastn 0 lparams)
-                    dashdash
-                    (nthlast 0 lparams))
-            body))))
+  (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 (lambda lparams . body) (expand-lambda-match clauses)
+      (let ((dashdash (member '-- params)))
+        (cons (append (ldiff params dashdash)
+                      (butlastn 0 lparams)
+                      dashdash
+                      (nthlast 0 lparams))
+              body)))))
 
 (defun non-triv-pat-p (syntax) t)