From: Eshel Yaron Date: Sat, 18 Jan 2025 21:30:43 +0000 (+0100) Subject: scope.el,elisp-mode.el: Improve 'rx' support X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=8ecb9865e50041e5842c541337317e63e757f41f;p=emacs.git scope.el,elisp-mode.el: Improve 'rx' support --- diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el index e1967c2afac..4d165d65e09 100644 --- 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 6fd9141e27b..39a6ed20ce6 100644 --- 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)