From 13d6e8fa54843b0b087e5a9c266e4b7e0d709c3f Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 16 Oct 2022 12:01:47 -0400 Subject: cl-generic: Fix `advertised-calling-convention` declarations * lisp/emacs-lisp/cl-generic.el (cl-generic-define-method): Preserve the `advertised-calling-convention`, if any (bug#58563). * lisp/subr.el (declare): Warn when we hit this. * lisp/emacs-lisp/byte-run.el (get-advertised-calling-convention): New fun. * lisp/progmodes/elisp-mode.el (elisp-get-fnsym-args-string): * lisp/help-fns.el (help-fns--signature): * lisp/emacs-lisp/bytecomp.el (byte-compile-fdefinition): Use it. * test/lisp/emacs-lisp/cl-generic-tests.el (cl-generic-tests--acc): New fun. (cl-generic-tests--advertised-calling-convention-bug58563): New test. --- lisp/emacs-lisp/byte-run.el | 5 +++++ lisp/emacs-lisp/bytecomp.el | 10 +++++----- lisp/emacs-lisp/cl-generic.el | 6 +++++- 3 files changed, 15 insertions(+), 6 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 9db84c31b88..a33808ab92d 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -481,6 +481,11 @@ convention was modified." (puthash (indirect-function function) signature advertised-signature-table)) +(defun get-advertised-calling-convention (function) + "Get the advertised SIGNATURE of FUNCTION. +Return t if there isn't any." + (gethash function advertised-signature-table t)) + (defun make-obsolete (obsolete-name current-name when) "Make the byte-compiler warn that function OBSOLETE-NAME is obsolete. OBSOLETE-NAME should be a function name or macro name (a symbol). diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 74ba8984f29..3ceb5da804f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1405,11 +1405,11 @@ when printing the error message." (and (not macro-p) (compiled-function-p (symbol-function fn))))) (setq fn (symbol-function fn))) - (let ((advertised (gethash (if (and (symbolp fn) (fboundp fn)) - ;; Could be a subr. - (symbol-function fn) - fn) - advertised-signature-table t))) + (let ((advertised (get-advertised-calling-convention + (if (and (symbolp fn) (fboundp fn)) + ;; Could be a subr. + (symbol-function fn) + fn)))) (cond ((listp advertised) (if macro-p diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index b3ade3b8943..7b6d43e572b 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -650,13 +650,17 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (cl--generic-name generic) qualifiers specializers)) current-load-list :test #'equal) - (let (;; Prevent `defalias' from recording this as the definition site of + (let ((old-adv-cc (get-advertised-calling-convention + (symbol-function sym))) + ;; Prevent `defalias' from recording this as the definition site of ;; the generic function. current-load-list ;; BEWARE! Don't purify this function definition, since that leads ;; to memory corruption if the hash-tables it holds are modified ;; (the GC doesn't trace those pointers). (purify-flag nil)) + (when (listp old-adv-cc) + (set-advertised-calling-convention gfun old-adv-cc nil)) ;; But do use `defalias', so that it interacts properly with nadvice, ;; e.g. for tracing/debug-on-entry. (defalias sym gfun))))) -- cgit v1.2.3 From 5176d006114390885a3a34fd80a8e25687558edc Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Mon, 17 Oct 2022 10:48:12 +0200 Subject: Avoid having the async compile log saying it's compiling loaddefs * lisp/loadup.el (featurep): Define the hash table in nativecomp builds (but not otherwise). A more natural place to define this would be in comp.el, but comp.el isn't loaded yet when we load the .elc file that updates comp--no-native-compile. We could change the load order and move the definition to comp.el, though. * lisp/emacs-lisp/bytecomp.el (byte-compile-from-buffer): Allow inhibiting nativecomp earlier (bug#57627). * lisp/emacs-lisp/comp.el (native-compile-async-skip-p): Use the data. --- lisp/emacs-lisp/bytecomp.el | 12 +++++++++--- lisp/emacs-lisp/comp.el | 1 + lisp/loadup.el | 5 ++++- 3 files changed, 14 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 3ceb5da804f..692a87f6d57 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2323,9 +2323,15 @@ With argument ARG, insert value in current buffer after the form." (setq case-fold-search nil)) (displaying-byte-compile-warnings (with-current-buffer inbuffer - (and byte-compile-current-file - (byte-compile-insert-header byte-compile-current-file - byte-compile--outbuffer)) + (when byte-compile-current-file + (byte-compile-insert-header byte-compile-current-file + byte-compile--outbuffer) + ;; Instruct native-comp to ignore this file. + (when (bound-and-true-p no-native-compile) + (with-current-buffer byte-compile--outbuffer + (insert + "(when (boundp 'comp--no-native-compile) + (puthash load-file-name t comp--no-native-compile))\n\n")))) (goto-char (point-min)) ;; Should we always do this? When calling multiple files, it ;; would be useful to delay this warning until all have been diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 889bffa3f5c..c300c44a8d7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4119,6 +4119,7 @@ the deferred compilation mechanism." LOAD and SELECTOR work as described in `native--compile-async'." ;; Make sure we are not already compiling `file' (bug#40838). (or (gethash file comp-async-compilations) + (gethash (file-name-with-extension file "elc") comp--no-native-compile) (cond ((null selector) nil) ((functionp selector) (not (funcall selector file))) diff --git a/lisp/loadup.el b/lisp/loadup.el index c01c827a75e..e940a32100c 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -501,7 +501,10 @@ lost after dumping"))) bin-dest-dir) ;; Relative filename from the built uninstalled binary. (file-relative-name file invocation-directory))))) - comp-loaded-comp-units-h)))) + comp-loaded-comp-units-h))) + ;; Set up the mechanism to allow inhibiting native-comp via + ;; file-local variables. + (defvar comp--no-native-compile (make-hash-table :test #'equal))) (when (hash-table-p purify-flag) (let ((strings 0) -- cgit v1.2.3 From b9aff5fdb89092b68ebd7782c8dc85e6daca14b2 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Mon, 17 Oct 2022 14:30:54 +0200 Subject: Fix spurious "Compilation finished" native-comp messages * lisp/emacs-lisp/comp.el (native--compile-async): Don't start the async compilation if we didn't add anything. This avoids spurious "Compilation finished" messages in the *Async* buffer when it turned out that all the files we considered nativecomping were skipped. --- lisp/emacs-lisp/comp.el | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c300c44a8d7..686c7aeb3db 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4167,7 +4167,8 @@ bytecode definition was not changed in the meantime)." (error "LOAD must be nil, t or 'late")) (unless (listp files) (setf files (list files))) - (let (file-list) + (let ((added-something nil) + file-list) (dolist (file-or-dir files) (cond ((file-directory-p file-or-dir) (dolist (file (if recursively @@ -4195,11 +4196,15 @@ bytecode definition was not changed in the meantime)." (make-directory out-dir t)) (if (file-writable-p out-filename) (setf comp-files-queue - (append comp-files-queue `((,file . ,load)))) + (append comp-files-queue `((,file . ,load))) + added-something t) (display-warning 'comp (format "No write access for %s skipping." out-filename))))))) - (when (zerop (comp-async-runnings)) + ;; Perhaps nothing passed `native-compile-async-skip-p'? + (when (and added-something + ;; Don't start if there's one already running. + (zerop (comp-async-runnings))) (comp-run-async-workers)))) -- cgit v1.2.3 From 40b734c5003c71dc533d588bb00ea51a983bd730 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Mon, 17 Oct 2022 15:26:21 +0200 Subject: Don't prune *.eln files in parent of eln-load-path * lisp/emacs-lisp/comp.el (native-compile-prune-cache): Don't prune *.eln files in parent directory of `native-comp-eln-load-path'. * test/lisp/emacs-lisp/comp-tests.el (test-native-compile-prune-cache/dont-delete-in-parent-of-cache): New test. --- lisp/emacs-lisp/comp.el | 4 +++- test/lisp/emacs-lisp/comp-tests.el | 11 +++++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 686c7aeb3db..460d260192d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4334,7 +4334,9 @@ of (commands) to run simultaneously." ;; `invocation-directory'. (setq dir (expand-file-name dir invocation-directory)) (when (file-exists-p dir) - (dolist (subdir (directory-files dir t)) + (dolist (subdir (seq-filter + (lambda (f) (not (string-match (rx "/." (? ".") eos) f))) + (directory-files dir t))) (when (and (file-directory-p subdir) (file-writable-p subdir) (not (equal (file-name-nondirectory diff --git a/test/lisp/emacs-lisp/comp-tests.el b/test/lisp/emacs-lisp/comp-tests.el index 97761cd728e..31f32dad1f5 100644 --- a/test/lisp/emacs-lisp/comp-tests.el +++ b/test/lisp/emacs-lisp/comp-tests.el @@ -59,4 +59,15 @@ (should (file-regular-p (expand-file-name "keep1.txt" c1))) (should (file-regular-p (expand-file-name "keep2.txt" c2))))) +(ert-deftest test-native-compile-prune-cache/dont-delete-in-parent-of-cache () + (skip-unless (featurep 'native-compile)) + (with-test-native-compile-prune-cache + (let ((f1 (expand-file-name "some.eln" (expand-file-name ".." testdir))) + (f2 (expand-file-name "some.eln" testdir))) + (with-temp-file f1 (insert "foo")) + (with-temp-file f2 (insert "foo")) + (native-compile-prune-cache) + (should (file-regular-p f1)) + (should (file-regular-p f2))))) + ;;; comp-tests.el ends here -- cgit v1.2.3 From eff4a4f49a7c45df9d27f0515c07d8e8727d84bb Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Mon, 17 Oct 2022 15:26:56 +0200 Subject: Improve native-compile-prune-cache messages * lisp/emacs-lisp/comp.el (native-compile-prune-cache): Quote name of pruned directory. --- lisp/emacs-lisp/comp.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 460d260192d..b7c792e64bd 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4342,7 +4342,7 @@ of (commands) to run simultaneously." (not (equal (file-name-nondirectory (directory-file-name subdir)) comp-native-version-dir))) - (message "Deleting %s..." subdir) + (message "Deleting `%s'..." subdir) ;; We're being overly cautious here -- there shouldn't be ;; anything but .eln files in these directories. (dolist (eln (directory-files subdir t "\\.eln\\(\\.tmp\\)?\\'")) -- cgit v1.2.3 From 1a8015b83761f27d299b1ffa45fc045bb76daf8a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 15 Oct 2022 00:59:55 +0200 Subject: * Prevent potential native compilation infinite recursions * lisp/emacs-lisp/comp.el (comp-no-spawn): New var. (comp-subr-trampoline-install, comp-final, comp-run-async-workers) (comp--native-compile): Update. --- lisp/emacs-lisp/comp.el | 168 ++++++++++++++++++++++++------------------------ 1 file changed, 85 insertions(+), 83 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b7c792e64bd..2c9b79334ba 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -687,6 +687,9 @@ Useful to hook into pass checkers.") 'native-compiler-error) +(defvar comp-no-spawn nil + "Non-nil don't spawn native compilation processes.") + ;; Moved early to avoid circularity when comp.el is loaded and ;; `macroexpand' needs to be advised (bug#47049). ;;;###autoload @@ -696,12 +699,9 @@ Useful to hook into pass checkers.") (memq subr-name native-comp-never-optimize-functions) (gethash subr-name comp-installed-trampolines-h)) (cl-assert (subr-primitive-p (symbol-function subr-name))) - (comp--install-trampoline - subr-name - (or (comp-trampoline-search subr-name) - (comp-trampoline-compile subr-name) - ;; Should never happen. - (cl-assert nil))))) + (when-let ((trampoline (or (comp-trampoline-search subr-name) + (comp-trampoline-compile subr-name)))) + (comp--install-trampoline subr-name trampoline)))) (cl-defstruct (comp-vec (:copier nil)) @@ -3689,7 +3689,8 @@ Prepare every function for final compilation and drive the C back-end." (print-circle t) (print-escape-multibyte t) (expr `((require 'comp) - (setf native-comp-verbose ,native-comp-verbose + (setf comp-no-spawn t + native-comp-verbose ,native-comp-verbose comp-libgccjit-reproducer ,comp-libgccjit-reproducer comp-ctxt ,comp-ctxt native-comp-eln-load-path ',native-comp-eln-load-path @@ -3945,8 +3946,9 @@ display a message." (file-newer-than-file-p source-file (comp-el-to-eln-filename source-file)))) do (let* ((expr `((require 'comp) - (setq comp-async-compilation t) - (setq warning-fill-column most-positive-fixnum) + (setq comp-async-compilation t + comp-no-spawn t + warning-fill-column most-positive-fixnum) ,(let ((set (list 'setq))) (dolist (var '(comp-file-preloaded-p native-compile-target-directory @@ -4046,72 +4048,73 @@ the deferred compilation mechanism." (stringp function-or-file)) (signal 'native-compiler-error (list "Not a function symbol or file" function-or-file))) - (catch 'no-native-compile - (let* ((print-symbols-bare t) - (data function-or-file) - (comp-native-compiling t) - (byte-native-qualities nil) - (symbols-with-pos-enabled t) - ;; Have byte compiler signal an error when compilation fails. - (byte-compile-debug t) - (comp-ctxt (make-comp-ctxt :output output - :with-late-load with-late-load))) - (comp-log "\n \n" 1) - (unwind-protect - (progn - (condition-case err - (cl-loop - with report = nil - for t0 = (current-time) - for pass in comp-passes - unless (memq pass comp-disabled-passes) - do - (comp-log (format "(%s) Running pass %s:\n" - function-or-file pass) - 2) - (setf data (funcall pass data)) - (push (cons pass (float-time (time-since t0))) report) - (cl-loop for f in (alist-get pass comp-post-pass-hooks) - do (funcall f data)) - finally - (when comp-log-time-report - (comp-log (format "Done compiling %s" data) 0) - (cl-loop for (pass . time) in (reverse report) - do (comp-log (format "Pass %s took: %fs." - pass time) 0)))) - (native-compiler-skip) - (t - (let ((err-val (cdr err))) - ;; If we are doing an async native compilation print the - ;; error in the correct format so is parsable and abort. - (if (and comp-async-compilation - (not (eq (car err) 'native-compiler-error))) - (progn - (message (if err-val - "%s: Error: %s %s" - "%s: Error %s") - function-or-file - (get (car err) 'error-message) - (car-safe err-val)) - (kill-emacs -1)) - ;; Otherwise re-signal it adding the compilation input. - (signal (car err) (if (consp err-val) - (cons function-or-file err-val) - (list function-or-file err-val))))))) - (if (stringp function-or-file) - data - ;; So we return the compiled function. - (native-elisp-load data))) - ;; We may have created a temporary file when we're being - ;; called with something other than a file as the argument. - ;; Delete it. - (when (and (not (stringp function-or-file)) - (not output) - comp-ctxt - (comp-ctxt-output comp-ctxt) - (file-exists-p (comp-ctxt-output comp-ctxt))) - (message "Deleting %s" (comp-ctxt-output comp-ctxt)) - (delete-file (comp-ctxt-output comp-ctxt))))))) + (unless comp-no-spawn + (catch 'no-native-compile + (let* ((print-symbols-bare t) + (data function-or-file) + (comp-native-compiling t) + (byte-native-qualities nil) + (symbols-with-pos-enabled t) + ;; Have byte compiler signal an error when compilation fails. + (byte-compile-debug t) + (comp-ctxt (make-comp-ctxt :output output + :with-late-load with-late-load))) + (comp-log "\n \n" 1) + (unwind-protect + (progn + (condition-case err + (cl-loop + with report = nil + for t0 = (current-time) + for pass in comp-passes + unless (memq pass comp-disabled-passes) + do + (comp-log (format "(%s) Running pass %s:\n" + function-or-file pass) + 2) + (setf data (funcall pass data)) + (push (cons pass (float-time (time-since t0))) report) + (cl-loop for f in (alist-get pass comp-post-pass-hooks) + do (funcall f data)) + finally + (when comp-log-time-report + (comp-log (format "Done compiling %s" data) 0) + (cl-loop for (pass . time) in (reverse report) + do (comp-log (format "Pass %s took: %fs." + pass time) 0)))) + (native-compiler-skip) + (t + (let ((err-val (cdr err))) + ;; If we are doing an async native compilation print the + ;; error in the correct format so is parsable and abort. + (if (and comp-async-compilation + (not (eq (car err) 'native-compiler-error))) + (progn + (message (if err-val + "%s: Error: %s %s" + "%s: Error %s") + function-or-file + (get (car err) 'error-message) + (car-safe err-val)) + (kill-emacs -1)) + ;; Otherwise re-signal it adding the compilation input. + (signal (car err) (if (consp err-val) + (cons function-or-file err-val) + (list function-or-file err-val))))))) + (if (stringp function-or-file) + data + ;; So we return the compiled function. + (native-elisp-load data))) + ;; We may have created a temporary file when we're being + ;; called with something other than a file as the argument. + ;; Delete it. + (when (and (not (stringp function-or-file)) + (not output) + comp-ctxt + (comp-ctxt-output comp-ctxt) + (file-exists-p (comp-ctxt-output comp-ctxt))) + (message "Deleting %s" (comp-ctxt-output comp-ctxt)) + (delete-file (comp-ctxt-output comp-ctxt)))))))) (defun native-compile-async-skip-p (file load selector) "Return non-nil if FILE's compilation should be skipped. @@ -4240,14 +4243,13 @@ Search happens in `native-comp-eln-load-path'." (defun native-compile (function-or-file &optional output) "Compile FUNCTION-OR-FILE into native code. This is the synchronous entry-point for the Emacs Lisp native -compiler. -FUNCTION-OR-FILE is a function symbol, a form, or the filename of -an Emacs Lisp source file. -If OUTPUT is non-nil, use it as the filename for the compiled -object. -If FUNCTION-OR-FILE is a filename, return the filename of the -compiled object. If FUNCTION-OR-FILE is a function symbol or a -form, return the compiled function." +compiler. FUNCTION-OR-FILE is a function symbol, a form, or the +filename of an Emacs Lisp source file. If OUTPUT is non-nil, use +it as the filename for the compiled object. If FUNCTION-OR-FILE +is a filename, if the compilation was successful return the +filename of the compiled object. If FUNCTION-OR-FILE is a +function symbol or a form, if the compilation was successful +return the compiled function." (comp--native-compile function-or-file nil output)) ;;;###autoload -- cgit v1.2.3 From 86581698acc1a0991592e018c1ba749f3ded21be Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 18 Oct 2022 13:14:08 +0200 Subject: Fix faulty loaddefs detection * lisp/emacs-lisp/loaddefs-gen.el (loaddefs-generate--emacs-batch): Fix faulty loaddefs detection. --- lisp/emacs-lisp/loaddefs-gen.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index a1c4f91579e..a76bcf604f7 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -738,7 +738,8 @@ rules for built-in packages and excluded files." (expand-file-name "emacs-lisp/loaddefs-gen.el" lisp-directory) output-file))) (let ((lisp-mode-autoload-regexp - "^;;;###\\(\\(noexist\\)-\\)?\\(theme-autoload\\)")) + ;; Avoid autoloads detection from loaddefs-gen. + (concat "^;;;###\\(\\(noexist\\)-\\)?\\(theme" "-autoload\\)"))) (loaddefs-generate (expand-file-name "../etc/themes/" lisp-directory) (expand-file-name "theme-loaddefs.el" lisp-directory)))) -- cgit v1.2.3 From 6cabef8799eb053c593f0a5241503ccbfb616c8a Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 18 Oct 2022 13:17:52 +0200 Subject: Fix previous loaddefs-gen fix --- lisp/emacs-lisp/loaddefs-gen.el | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index a76bcf604f7..ecc5f7e47bd 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -738,13 +738,12 @@ rules for built-in packages and excluded files." (expand-file-name "emacs-lisp/loaddefs-gen.el" lisp-directory) output-file))) (let ((lisp-mode-autoload-regexp - ;; Avoid autoloads detection from loaddefs-gen. - (concat "^;;;###\\(\\(noexist\\)-\\)?\\(theme" "-autoload\\)"))) + "^;;;###\\(\\(noexist\\)-\\)?\\(theme-autoload\\)")) (loaddefs-generate (expand-file-name "../etc/themes/" lisp-directory) (expand-file-name "theme-loaddefs.el" lisp-directory)))) -;;;###autoload (load "theme-loaddefs.el") +;;;###autoload (load "theme-loaddefs.el" t) (provide 'loaddefs-gen) -- cgit v1.2.3 From c5e256677402b8f8745df503476a210bbf84a258 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 18 Oct 2022 10:49:43 -0400 Subject: (byte-compile--first-symbol-with-pos): Fix bug#58601 * lisp/emacs-lisp/bytecomp.el: Require `subr-x`. (byte-compile--first-symbol-with-pos): Avoid inf-loops on circular data. --- lisp/emacs-lisp/bytecomp.el | 38 +++++++++++++++++--------------------- 1 file changed, 17 insertions(+), 21 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 692a87f6d57..f0265682172 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -129,6 +129,7 @@ ;; us from emitting warnings when compiling files which use cl-lib without ;; requiring it! (bug#30635) (eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) ;; The feature of compiling in a specific target Emacs version ;; has been turned off because compile time options are a bad idea. @@ -1185,27 +1186,22 @@ message buffer `default-directory'." (defun byte-compile--first-symbol-with-pos (form) "Return the first symbol with position in form, or nil if none. Order is by depth-first search." - (cond - ((symbol-with-pos-p form) form) - ((consp form) - (or (byte-compile--first-symbol-with-pos (car form)) - (let ((sym nil)) - (setq form (cdr form)) - (while (and (consp form) - (not (setq sym (byte-compile--first-symbol-with-pos - (car form))))) - (setq form (cdr form))) - (or sym - (and form (byte-compile--first-symbol-with-pos form)))))) - ((or (vectorp form) (recordp form)) - (let ((len (length form)) - (i 0) - (sym nil)) - (while (and (< i len) - (not (setq sym (byte-compile--first-symbol-with-pos - (aref form i))))) - (setq i (1+ i))) - sym)))) + (named-let loop ((form form) + (depth 10)) ;Arbitrary limit. + (cond + ((<= depth 0) nil) ;Avoid cycles (bug#58601). + ((symbol-with-pos-p form) form) + ((consp form) + (or (loop (car form) (1- depth)) + (loop (cdr form) (1- depth)))) + ((or (vectorp form) (recordp form)) + (let ((len (length form)) + (i 0) + (sym nil)) + (while (and (< i len) + (not (setq sym (loop (aref form i) (1- depth))))) + (setq i (1+ i))) + sym))))) (defun byte-compile--warning-source-offset () "Return a source offset from `byte-compile-form-stack' or nil if none." -- cgit v1.2.3