diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 50e90cdf94c..5ed8f60f241 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -90,7 +90,7 @@ generated-autoload-file The autoload file is assumed to contain a trailer starting with a FormFeed character.") ;;;###autoload -(put 'generated-autoload-file 'safe-local-variable 'stringp) +(put 'generated-autoload-file 'safe-local-variable #'stringp) (defvar generated-autoload-load-name nil "Load name for `autoload' statements generated from autoload cookies. @@ -99,7 +99,7 @@ generated-autoload-load-name is not in `load-path'. This also affects the generated cus-load.el file.") ;;;###autoload -(put 'generated-autoload-load-name 'safe-local-variable 'stringp) +(put 'generated-autoload-load-name 'safe-local-variable #'stringp) (defun loaddefs-generate--file-load-name (file outfile) "Compute the name that will be used to load FILE. @@ -325,54 +325,103 @@ loaddefs-generate--make-autoload ;; nil here indicates that this is not a special autoload form. (t nil)))) +(defvar loaddefs-generate-prefixes-limit 8 + "Max number of prefixes registered per file.") + +(defvar loaddefs-generate-prefixes-generic + '("find-" "make-" "copy-" "define-" "global-" "batch-") + "Prefixes which are not specific enough.") + +(defvar loaddefs-generate-prefixes-ignore () + "List of prefixes that are not worth registering. +Meant to be used as a file-local variable.") + (defun loaddefs-generate--make-prefixes (defs file) - ;; Remove the defs that obey the rule that file foo.el (or - ;; foo-mode.el) uses "foo-" as prefix. Then compute a small set of - ;; prefixes that cover all the remaining definitions. - (let* ((tree (let ((tree radix-tree-empty)) - (dolist (def defs) - (setq tree (radix-tree-insert tree def t))) - tree)) - (prefixes nil)) - ;; Get the root prefixes, that we should include in any case. - (radix-tree-iter-subtrees - tree (lambda (prefix subtree) - (push (cons prefix subtree) prefixes))) - ;; In some cases, the root prefixes are too short, e.g. if you define - ;; "cc-helper" and "c-mode", you'll get "c" in the root prefixes. - (dolist (pair (prog1 prefixes (setq prefixes nil))) - (let ((s (car pair))) - (if (or (and (> (length s) 2) ; Long enough! - ;; But don't use "def" from deffoo-pkg-thing. - (not (string= "def" s))) - (string-match ".[[:punct:]]\\'" s) ;A real (tho short) prefix? - (radix-tree-lookup (cdr pair) "")) ;Nothing to expand! - (push pair prefixes) ;Keep it as is. - (radix-tree-iter-subtrees - (cdr pair) (lambda (prefix subtree) - (push (cons (concat s prefix) subtree) prefixes)))))) - (when prefixes - (let ((strings - (mapcar - (lambda (x) - (let ((prefix (car x))) - (if (or (> (length prefix) 2) ;Long enough! - (and (eq (length prefix) 2) - (string-match "[[:punct:]]" prefix))) - prefix - ;; Some packages really don't follow the rules. - ;; Drop the most egregious cases such as the - ;; one-letter prefixes. - (let ((dropped ())) - (radix-tree-iter-mappings - (cdr x) (lambda (s _) - (push (concat prefix s) dropped))) - (message "%s:0: Warning: Not registering prefix \"%s\". Affects: %S" - file prefix dropped) - nil)))) - prefixes))) - `(register-definition-prefixes ,file ',(sort (delq nil strings) - 'string<)))))) + ;; FIXME: We should take advantage of (and encourage) the convention + ;; of using the same namespace prefix as the file name. + ;; (message "loaddefs-generate-prefixes-ignore in %S = %S" + ;; file loaddefs-generate-prefixes-ignore) + (letrec + ;; First, convert the list of DEFS into a radix tree. + ((tree (let ((tree radix-tree-empty)) + (dolist (def defs) + (setq tree (radix-tree-insert tree def t))) + tree)) + (valid-prefix-p ;; Avoid prefixes that are excessively generic. + (lambda (s) + (and (or (> (length s) 2) ;Long enough! + ;; A real (tho short) prefix? + (string-match ".[[:punct:]]\\'" s)) + ;; But avoid generic prefixes. + (let ((x (try-completion s loaddefs-generate-prefixes-generic))) + (not (or (equal x s) (equal x t))))))) + (ignore-p + (lambda (s) + (or (not (listp loaddefs-generate-prefixes-ignore)) + (let ((ignore nil)) + (dolist (ignored-prefix loaddefs-generate-prefixes-ignore) + (when (string-prefix-p ignored-prefix s) + (setq ignore t))) + ignore)))) + (ids ;; Convert a radix (sub)tree back into a list of identifiers. + (lambda (prefix tree) + (let ((ids '())) + (radix-tree-iter-mappings + tree (lambda (s _) (push (concat prefix s) ids))) + ids))) + (dropped '()) ;; List of prefixes that are rejected. + (valid-prefixes ;; Return possible valid prefixes of a (sub)tree. + (lambda (prefix tree) + (let ((prefixes '())) + (radix-tree-iter-subtrees + tree + (lambda (s subtree) + (setq s (concat prefix s)) + (cond + ((funcall ignore-p s)) ;; Drop silently. + ((funcall valid-prefix-p s) (push (cons s subtree) prefixes)) + ((radix-tree-lookup tree "") ;Nothing to expand! + (push (cons s (funcall ids prefix subtree)) dropped)) + (t + (setq prefixes (nconc (funcall valid-prefixes s subtree) + prefixes)))))) + prefixes))) + ;; Initial list of possible valid prefixes. + (prefixes (funcall valid-prefixes "" tree))) + (when (> (length prefixes) loaddefs-generate-prefixes-limit) + ;; The list is too long. Throw out the prefixes that cover fewer + ;; identifiers: they're less useful (and they tend to be longer). + (let* ((sorted + (sort + (mapcar (lambda (x) + (let ((prefix (car x)) (tree (cdr x))) + (cons prefix (funcall ids prefix tree)))) + prefixes) + (lambda (x y) (> (length (cdr x)) (length (cdr y))))))) + (setq dropped (nconc (nthcdr loaddefs-generate-prefixes-limit sorted) dropped)) + (setq prefixes (nreverse (take loaddefs-generate-prefixes-limit sorted))) + ;; Don't keep prefixes that contain no-more elements than dropped ones, + ;; so we're not affected by arbitrary ordering between subtrees. + (while (= (length (cdar prefixes)) (length (cdar dropped))) + (push (pop prefixes) dropped)))) + (when dropped + (let ((ids (mapcan #'cdr dropped))) + (message "%s:0: Warning: Not registering %d prefixes (%d (%d%%) identifiers). +Affected prefixes: %S" + file (length dropped) (length ids) + (/ (* (length ids) 100) + (+ (length ids) (length (mapcan #'cdr prefixes)))) + (mapcar #'car dropped)))) ;;ids + (let ((expd (when dropped + `(ignore "dropped-prefixes" ',(mapcar #'car dropped)))) + (expr + (when prefixes + (let ((strings (mapcar #'car prefixes))) + `(register-definition-prefixes + ,file ',(sort strings #'string<)))))) + (if (and expd expr) + `(progn ,expr ,expd) + (or expd expr))))) (defun loaddefs-generate--parse-file (file main-outfile &optional package-data) "Examining FILE for ;;;###autoload statements. @@ -386,45 +435,45 @@ loaddefs-generate--parse-file don't include." (let ((defs nil) (load-name (loaddefs-generate--file-load-name file main-outfile)) - (compute-prefixes t) read-symbol-shorthands - local-outfile inhibit-autoloads) + local-outfile) (with-temp-buffer (insert-file-contents file) (goto-char (point-max)) ;; We "open-code" this version of `hack-local-variables', ;; because it's really slow in bootstrap-emacs. + ;; FIXME: That fails to obey `dir-locals.el'! (when (search-backward ";; Local Variables:" (- (point-max) 1000) t) - (save-excursion - (when (re-search-forward "generated-autoload-file: *" nil t) - ;; Buffer-local file that should be interpreted relative to - ;; the .el file. - (setq local-outfile (expand-file-name (read (current-buffer)) - (file-name-directory file))))) - (save-excursion - (when (re-search-forward "generated-autoload-load-name: *" nil t) - (setq load-name (read (current-buffer))))) - (save-excursion - (when (re-search-forward "no-update-autoloads: *" nil t) - (setq inhibit-autoloads (read (current-buffer))))) - (save-excursion - (when (re-search-forward "autoload-compute-prefixes: *" nil t) - (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-let ((beg - (re-search-forward "read-symbol-shorthands: *" nil t))) - ;; `read-symbol-shorthands' alist ends with two parens. - (let* ((end (re-search-forward ")[;\n\s]*)")) - (commentless (replace-regexp-in-string - "\n\\s-*;+" "" - (buffer-substring beg end))) - (unsorted-shorthands (car (read-from-string commentless)))) - (setq read-symbol-shorthands - (sort unsorted-shorthands - (lambda (sh1 sh2) - (> (length (car sh1)) (length (car sh2)))))))))) + (while (re-search-forward + (concat (regexp-opt + '("generated-autoload-file" + "generated-autoload-load-name" + "no-update-autoloads" + "autoload-compute-prefixes" + "read-symbol-shorthands" + "loaddefs-generate-prefixes-ignore") + t) + ": *") + nil t) + (condition-case err + (set (make-local-variable (intern (match-string 1))) + (read (current-buffer))) + (error + (message "Error while reading local var %S: %S" + (match-string 1) err)))) + (when (local-variable-p 'generated-autoload-file) + ;; Buffer-local file that should be interpreted relative to + ;; the .el file. + (setq local-outfile (expand-file-name generated-autoload-file + (file-name-directory file)))) + (when (local-variable-p 'generated-autoload-load-name) + (setq load-name generated-autoload-load-name)) + (when (local-variable-p 'read-symbol-shorthands) + ;; Duplicate the logic in `hack-local-variables--find-variables'. + (setq read-symbol-shorthands + (sort read-symbol-shorthands + (lambda (sh1 sh2) + (> (length (car sh1)) (length (car sh2)))))))) ;; We always return the package version (even for pre-dumped ;; files). @@ -446,7 +495,7 @@ loaddefs-generate--parse-file defs)))) ;; Obey the `no-update-autoloads' file local variable. - (when (and (not inhibit-autoloads) + (when (and (not no-update-autoloads) (not (eq package-data 'only))) (goto-char (point-min)) ;; The cookie might be like ;;;###tramp-autoload... @@ -496,8 +545,7 @@ loaddefs-generate--parse-file (buffer-substring (point) (line-end-position))) defs))))) - (when (and autoload-compute-prefixes - compute-prefixes) + (when autoload-compute-prefixes (with-demoted-errors "%S" (when-let ((form (loaddefs-generate--compute-prefixes load-name)))