scope.el: Handle more pcase patterns

diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el
index fe575611e7efb7db6f5bc910bae6c866d8ceec9c..098012e2301a8af9ecf2bed1c5672419a386c5ae 100644 (file)
--- a/lisp/emacs-lisp/scope.el
+++ b/lisp/emacs-lisp/scope.el
@@ -343,20 +343,55 @@ Optional argument LOCAL is a local context to extend."
    ;; FIXME: Support vector qpats.
    (t (list local))))
 
+(defun scope-pcase-and (local patterns)
+  (if patterns
+      (let* ((l-r0 (scope-pcase-pattern local (car patterns)))
+             (l (car l-r0))
+             (r0 (cdr l-r0))
+             (l-r (scope-pcase-and l (cdr patterns))))
+        (cons (car l-r) (nconc r0 (cdr l-r))))
+    (list local)))
+
 (defun scope-pcase-pattern (local pattern)
   (cond
    ((symbol-with-pos-p pattern)
     (let ((bare (bare-symbol pattern)))
-      (if (eq bare '_) (list local)
+      (if (or (eq bare '_) (keywordp bare)) (list local)
+        ;; FIXME: Keep track of symbols bound here and analyze
+        ;; subsequent symbol patterns with the same symbol as equality
+        ;; tests, not new bindings.
         (let* ((beg (symbol-with-pos-pos pattern)))
           (cons (scope-local-new bare beg local)
                 (list (list beg (length (symbol-name bare)) beg)))))))
    ((consp pattern)
-    (cond
-     ((eq (car pattern) '\`)
-      (scope-pcase-qpat local (cadr pattern)))
-     ;; FIXME: Refine.
-     (t (list local))))))
+    (let ((head (car pattern)))
+      (cond
+       ((eq head '\`)
+        (scope-pcase-qpat local (cadr pattern)))
+       ((eq head 'quote) (list local))
+       ((symbol-with-pos-p head)
+        (let ((bh (bare-symbol head)))
+          (cond
+           ((eq bh 'pred)
+            ;; FIXME: Analyze FUN at (cadr pattern).
+            (list local))
+           ((eq bh 'app)
+            ;; FIXME: Likewise here.
+            (scope-pcase-pattern local (caddr pattern)))
+           ((eq bh 'guard) (cons local (scope-1 local (cadr pattern))))
+           ((eq bh 'cl-type) (list local))
+           ((eq bh 'let)
+            (let ((r0 (scope-1 local (caddr pattern)))
+                  (l-r (scope-pcase-pattern local (cadr pattern))))
+              (cons (car l-r) (nconc r0 (cdr l-r)))))
+           ((eq bh 'and) (scope-pcase-and local (cdr pattern)))
+           ((eq bh 'or)
+            ;; FIXME: `or' patterns deserve special handling because
+            ;; they can create multiple binding positions for the same
+            ;; symbol in different subpatterns, and the effective
+            ;; binding position can only be determined at run time.
+            (scope-pcase-and local (cdr pattern)))))))))
+   ((or (integerp pattern) (stringp pattern)) (list local))))
 
 (defun scope-pcase-1 (local pattern body)
   (let* ((l-r (scope-pcase-pattern local pattern))