bug#67390: 28; shorthands-font-lock-shorthands assumes shorthand uses same separator

[João Távora]

Hi all,

I've been working on all these shorthand-related issues over the last
two days and I have reasonably short fixes for all of them.

For this particular issue (bug#67309), I've opted to
use Joseph's patch with very slight adjustments, as it's the
only one that guarantees correct behaviour and doesn't seem
to impact performance.

The other issues are:

bug#63480 (loaddefs-gen.el doesn't know about shorthands)
bug#67325 (prefix discovery i.e. register-definition-prefixes)
bug#67523 (check-declare.el doesn't know about shorthands)

I have all this in 6 commits in the bugfix/shorthand-fixes branch.

Here's the full patch minus whitespace changes.  If there are
no comments I'll push in a few days' time.

João

diff --git a/doc/lispref/symbols.texi b/doc/lispref/symbols.texi
index 1f3b677d7fb..18e80311177 100644
--- a/doc/lispref/symbols.texi
+++ b/doc/lispref/symbols.texi
@@ -761,6 +761,23 @@ Shorthands
 ;; End:
 @end example

+Note that if you have two shorthands in the same file where one is the
+prefix of the other, the longer shorthand will be attempted first.
+This happens regardless of the order you specify shorthands in the
+local variables section of your file.
+
+@example
+'(
+  t//foo ; reads to 'my-tricks--foo', not 'my-tricks-/foo'
+  t/foo  ; reads to 'my-tricks-foo'
+  )
+
+;; Local Variables:
+;; read-symbol-shorthands: (("t/" . "my-tricks-")
+;;                          ("t//" . "my-tricks--")
+;; End:
+@end example
+
 @subsection Exceptions

 There are two exceptions to rules governing Shorthand transformations:
diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el
index c887d95210c..b19aedf314d 100644
--- a/lisp/emacs-lisp/check-declare.el
+++ b/lisp/emacs-lisp/check-declare.el
@@ -145,21 +145,26 @@ check-declare-verify
     (if (file-regular-p fnfile)
         (with-temp-buffer
           (insert-file-contents fnfile)
+          (unless cflag
+            ;; If in Elisp, ensure syntax and shorthands available
+            (set-syntax-table emacs-lisp-mode-syntax-table)
+            (let (enable-local-variables) (hack-local-variables)))
           ;; defsubst's don't _have_ to be known at compile time.
-          (setq re (format (if cflag
-                               "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\""
+          (setq re (if cflag
+                       (format "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\""
+                               (regexp-opt (mapcar 'cadr fnlist) t))
                      "^[ \t]*(\\(fset[ \t]+'\\|\
 cl-def\\(?:generic\\|method\\|un\\)\\|\
 def\\(?:un\\|subst\\|foo\\|method\\|class\\|\
 ine-\\(?:derived\\|generic\\|\\(?:global\\(?:ized\\)?-\\)?minor\\)-mode\\|\
 \\(?:ine-obsolete-function-\\)?alias[ \t]+'\\|\
 ine-overloadable-function\\)\\)\
-[ \t]*%s\\([ \t;]+\\|$\\)")
-                           (regexp-opt (mapcar 'cadr fnlist) t)))
+[ \t]*\\(\\(?:\\sw\\|\\s_\\)+\\)\\([ \t;]+\\|$\\)"))
           (while (re-search-forward re nil t)
             (skip-chars-forward " \t\n")
-            (setq fn (match-string 2)
-                  type (match-string 1)
+            (setq fn (symbol-name (car (read-from-string (match-string 2)))))
+            (when (member fn (mapcar 'cadr fnlist))
+              (setq type (match-string 1)
                     ;; (min . max) for a fixed number of arguments, or
                     ;; arglists with optional elements.
                     ;; (min) for arglists with &rest.
@@ -202,7 +207,7 @@ check-declare-verify
                               (t
                                'err))
                     ;; alist of functions and arglist signatures.
-                  siglist (cons (cons fn sig) siglist)))))
+                    siglist (cons (cons fn sig) siglist))))))
     (dolist (e fnlist)
       (setq arglist (nth 2 e)
             type
diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el
index 04bea4723a2..e8093200bec 100644
--- a/lisp/emacs-lisp/loaddefs-gen.el
+++ b/lisp/emacs-lisp/loaddefs-gen.el
@@ -378,6 +378,7 @@ loaddefs-generate--parse-file
   (let ((defs nil)
         (load-name (loaddefs-generate--file-load-name file main-outfile))
         (compute-prefixes t)
+        read-symbol-shorthands
         local-outfile inhibit-autoloads)
     (with-temp-buffer
       (insert-file-contents file)
@@ -399,7 +400,19 @@ loaddefs-generate--parse-file
             (setq inhibit-autoloads (read (current-buffer)))))
         (save-excursion
           (when (re-search-forward "autoload-compute-prefixes: *" nil t)
-            (setq compute-prefixes (read (current-buffer))))))
+            (setq compute-prefixes (read (current-buffer)))))
+        (save-excursion
+          ;; since we're "open-coding" we have to repeat more
+          ;; complicated logic in `hack-local-variables'.
+          (when (re-search-forward "read-symbol-shorthands: *" nil t)
+            (let* ((commentless (replace-regexp-in-string
+                                 "\n\\s-*;+" ""
+                                 (buffer-substring (point) (point-max))))
+                   (unsorted-shorthands (car (read-from-string commentless))))
+              (setq read-symbol-shorthands
+                    (sort unsorted-shorthands
+                          (lambda (sh1 sh2)
+                            (> (length (car sh1)) (length (car sh2))))))))))

       ;; We always return the package version (even for pre-dumped
       ;; files).
@@ -486,7 +499,11 @@ loaddefs-generate--compute-prefixes
     (while (re-search-forward
             "^(\\(def[^ \t\n]+\\)[ \t\n]+['(]*\\([^' ()\"\n]+\\)[\n \t]" nil t)
       (unless (member (match-string 1) autoload-ignored-definitions)
-        (let ((name (match-string-no-properties 2)))
+        (let* ((name (match-string-no-properties 2))
+               ;; Consider `read-symbol-shorthands'.
+               (probe (let ((obarray (obarray-make)))
+                        (car (read-from-string name)))))
+          (setq name (symbol-name probe))
           (when (save-excursion
                   (goto-char (match-beginning 0))
                   (or (bobp)
diff --git a/lisp/emacs-lisp/shorthands.el b/lisp/emacs-lisp/shorthands.el
index b0665a55695..69b562e3c7e 100644
--- a/lisp/emacs-lisp/shorthands.el
+++ b/lisp/emacs-lisp/shorthands.el
@@ -52,38 +52,26 @@ elisp-shorthand-font-lock-face
   :version "28.1"
   :group 'font-lock-faces)

-(defun shorthands--mismatch-from-end (str1 str2)
-  "Tell index of first mismatch in STR1 and STR2, from end.
-The index is a valid 0-based index on STR1.  Returns nil if STR1
-equals STR2.  Return 0 if STR1 is a suffix of STR2."
-  (cl-loop with l1 = (length str1) with l2 = (length str2)
-           for i from 1
-           for i1 = (- l1 i) for i2 = (- l2 i)
-           while (eq (aref str1 i1) (aref str2 i2))
-           if (zerop i2) return (if (zerop i1) nil i1)
-           if (zerop i1) return 0
-           finally (return i1)))
-
 (defun shorthands-font-lock-shorthands (limit)
+  "Font lock until LIMIT considering `read-symbol-shorthands'."
   (when read-symbol-shorthands
     (while (re-search-forward
             (concat "\\_<\\(" (rx lisp-mode-symbol) "\\)\\_>")
             limit t)
       (let* ((existing (get-text-property (match-beginning 1) 'face))
+             (print-name (match-string 1))
              (probe (and (not (memq existing '(font-lock-comment-face
                                                font-lock-string-face)))
-                         (intern-soft (match-string 1))))
-             (sname (and probe (symbol-name probe)))
-             (mismatch (and sname (shorthands--mismatch-from-end
-                                   (match-string 1) sname)))
-             (guess (and mismatch (1+ mismatch))))
-        (when guess
-          (when (and (< guess (1- (length (match-string 1))))
-                     ;; In bug#67390 we allow other separators
-                     (eq (char-syntax (aref (match-string 1) guess)) ?_))
-            (setq guess (1+ guess)))
+                         (intern-soft print-name)))
+             (symbol-name (and probe (symbol-name probe)))
+             (prefix (and symbol-name
+                          (not (string-equal print-name symbol-name))
+                          (car (assoc print-name
+                                      read-symbol-shorthands
+                                      #'string-prefix-p)))))
+        (when prefix
           (add-face-text-property (match-beginning 1)
-                                  (+ (match-beginning 1) guess)
+                                  (+ (match-beginning 1) (length prefix))
                                   'elisp-shorthand-font-lock-face))))))

 (font-lock-add-keywords 'emacs-lisp-mode
'((shorthands-font-lock-shorthands)) t)
diff --git a/lisp/files.el b/lisp/files.el
index 1cdcec23b11..b266d0727ec 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -3735,7 +3735,8 @@ before-hack-local-variables-hook
 This hook is called only if there is at least one file-local
 variable to set.")

-(defvar permanently-enabled-local-variables '(lexical-binding)
+(defvar permanently-enabled-local-variables
+  '(lexical-binding read-symbol-shorthands)
   "A list of file-local variables that are always enabled.
 This overrides any `enable-local-variables' setting.")

@@ -4171,6 +4172,13 @@ hack-local-variables--find-variables
                                 ;; to use 'thisbuf's name in the
                                 ;; warning message.
                                 (or (buffer-file-name thisbuf) ""))))))
+                          ((eq var 'read-symbol-shorthands)
+                           ;; Sort automatically by shorthand length
+                           ;; descending
+                           (setq val (sort val
+                                           (lambda (sh1 sh2) (>
(length (car sh1))
+
(length (car sh2))))))
+                           (push (cons 'read-symbol-shorthands val) result))
                           ((and (eq var 'mode) handle-mode))
    (t
     (ignore-errors