scope.el,elisp-mode.el: Improve 'rx' support

diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el
index e1967c2afac272fa084fc48821a5383eb6707f6f..4d165d65e0945eb4ab295a32d872c04fc24ac79c 100644 (file)
--- a/lisp/emacs-lisp/scope.el
+++ b/lisp/emacs-lisp/scope.el
@@ -500,10 +500,18 @@ Optional argument LOCAL is a local context to extend."
   (scope-let local spec-list body))
 
 (defun scope-rx (local regexps)
-  (dolist (regexp regexps)
-    (when (consp regexp)
+  (dolist (regexp regexps) (scope-rx-1 local regexp)))
+
+(defvar scope-rx-alist nil)
+
+(defun scope-rx-1 (local regexp)
+  (if (consp regexp)
       (let* ((head (car regexp))
              (bare (scope-sym-bare head)))
+        (when bare
+          (funcall scope-callback 'rx-construct
+                   (symbol-with-pos-pos head) (length (symbol-name bare))
+                   (alist-get bare scope-rx-alist)))
         (cond
          ((memq bare '(literal regex regexp eval))
           (scope-1 local (cadr regexp)))
@@ -511,12 +519,80 @@ Optional argument LOCAL is a local context to extend."
                         or |
                         zero-or-more 0+ * *?
                         one-or-more 1+ + +?
-                        zero-or-one optional opt ? ??
+                        zero-or-one optional opt \? \??
                         = >= ** repeat
                         minimal-match maximal-match
                         group submatch
                         group-n submatch-n))
-          (scope-rx local (cdr regexp))))))))
+          (scope-rx local (cdr regexp)))))
+    (when-let ((bare (scope-sym-bare regexp)))
+      (funcall scope-callback 'rx-construct
+               (symbol-with-pos-pos regexp) (length (symbol-name bare))
+               (alist-get bare scope-rx-alist)))))
+
+(defun scope-rx-define (local name rest)
+  (when-let ((bare (scope-sym-bare name)))
+    (funcall scope-callback 'rx-construct
+             (symbol-with-pos-pos name) (length (symbol-name bare)) nil))
+  (if (not (cdr rest))
+      (scope-rx-1 local (car rest))
+    (let ((l scope-rx-alist)
+          (args (car rest))
+          (rx (cadr rest)))
+      (dolist (arg args)
+        (and (symbol-with-pos-p arg)
+             (let* ((beg (symbol-with-pos-pos arg))
+                    (bare (bare-symbol arg))
+                    (len (length (symbol-name bare))))
+               (when beg
+                 (if (memq (bare-symbol arg) '(&optional &rest _))
+                     (funcall scope-callback 'ampersand beg len nil)
+                   (funcall scope-callback 'rx-construct beg len beg))))))
+      (dolist (arg args)
+        (when-let ((bare (bare-symbol arg))
+                   (beg (scope-sym-pos arg)))
+          (unless (memq bare '(&optional &rest))
+            (setq l (scope-local-new bare beg l)))))
+      (let ((scope-rx-alist l))
+        (scope-rx-1 local rx)))))
+
+(defun scope-rx-let (local bindings body)
+  (if-let ((binding (car bindings)))
+      (let ((name (car binding)) (rest (cdr binding)))
+        (when-let ((bare (scope-sym-bare name))
+                   (beg (symbol-with-pos-pos name)))
+          (funcall scope-callback 'rx-construct
+                   beg (length (symbol-name bare)) beg))
+        (if (cdr rest)
+            (let ((l scope-rx-alist)
+                  (args (car rest))
+                  (rx (cadr rest)))
+              (dolist (arg args)
+                (and (symbol-with-pos-p arg)
+                     (let* ((beg (symbol-with-pos-pos arg))
+                            (bare (bare-symbol arg))
+                            (len (length (symbol-name bare))))
+                       (when beg
+                         (if (memq (bare-symbol arg) '(&optional &rest _))
+                             (funcall scope-callback 'ampersand beg len nil)
+                           (funcall scope-callback 'rx-construct beg len beg))))))
+              (dolist (arg args)
+                (when-let ((bare (bare-symbol arg))
+                           (beg (scope-sym-pos arg)))
+                  (unless (memq bare '(&optional &rest))
+                    (setq l (scope-local-new bare beg l)))))
+              (let ((scope-rx-alist l))
+                (scope-rx-1 local rx))
+              (let ((scope-rx-alist (scope-local-new (scope-sym-bare name)
+                                                     (scope-sym-pos name)
+                                                     scope-rx-alist)))
+                (scope-rx-let local (cdr bindings) body)))
+          (scope-rx-1 local (car rest))
+          (let ((scope-rx-alist (scope-local-new (scope-sym-bare name)
+                                                 (scope-sym-pos name)
+                                                 scope-rx-alist)))
+            (scope-rx-let local (cdr bindings) body))))
+    (scope-n local body)))
 
 (defun scope-gv-define-expander (local name handler)
   (when-let* ((beg (scope-sym-pos name)) (bare (scope-sym-bare name)))
@@ -909,6 +985,12 @@ a (possibly empty) list of safe macros.")
             (scope-return-from local (car forms) (cadr forms)))
            ((memq bare '(rx))           ; `rx' is unsafe, never expand!
             (scope-rx local forms))
+           ((memq bare '(rx-define))
+            (scope-rx-define local (car forms) (cdr forms)))
+           ((memq bare '(rx-let))
+            (scope-rx-let local (car forms) (cdr forms)))
+           ;; ((memq bare '(rx-let-eval))
+           ;;  (scope-rx-let-eval local (car forms) (cdr forms)))
            ((memq bare '(let-when-compile)) ; `let-when-compile' too!
             (scope-let* local (car forms) (cdr forms)))
            ((memq bare '(cl-eval-when)) ; Likewise!

diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
index 6fd9141e27be056aca88a9ff00b551527236d17a..39a6ed20ce69d691b9e9c5c83f75e72f830a400d 100644 (file)
--- a/lisp/progmodes/elisp-mode.el
+++ b/lisp/progmodes/elisp-mode.el
@@ -359,6 +359,10 @@ happens in interactive invocations."
   "Face for highlighting feature names in Emacs Lisp code."
   :group 'lisp)
 
+(defface elisp-rx '((t :foreground "#00008b"))
+  "Face for highlighting `rx' constructs in Emacs Lisp code."
+  :group 'lisp)
+
 (defface elisp-theme '((t :inherit font-lock-constant-face))
   "Face for highlighting custom theme names in Emacs Lisp code."
   :group 'lisp)
@@ -430,6 +434,7 @@ happens in interactive invocations."
      (special-form  "Special form")
      (throw-tag     "`throw'/`catch' tag")
      (feature       "Feature")
+     (rx-construct  "`rx' construct")
      (theme         "Theme")
      (widget-type   "Widget type")
      (type          "Type")
@@ -453,6 +458,7 @@ happens in interactive invocations."
                          (special-form  'elisp-special-form)
                          (throw-tag     'elisp-throw-tag)
                          (feature       'elisp-feature)
+                         (rx-construct  'elisp-rx)
                          (theme         'elisp-theme)
                          (widget-type   'font-lock-type-face)
                          (type          'font-lock-type-face)