Miscellaneous enhancements to scratch/correct-warning-pos.

1. Check the type (symbol with position) of the argument given to the native
compiled version of SYMBOL_WITH_POS_SYM.
2. Handle infinite recursion caused by circular lists, etc., in
macroexp-strip-symbol-positions by using hash tables.
3. Read byte compiled functions without giving symbols positions.

* lisp/emacs-lisp/comp.el (comp-finalize-relocs): Add symbol-with-pos-p into
the list of relocated symbols.

* lisp/emacs-lisp/macroexp.el (macroexp--ssp-conses-seen)
(macroexp--ssp-vectors-seen, macroexp--ssp-records-seen): Renamed, and
animated as hash tables.
(macroexp--strip-s-p-2): Optionally tests for the presence of an argument in
one of the above hash tables, so as to handle otherwise infinite recursion.
(byte-compile-strip-s-p-1): Add a condition-case to handle infinite recursion
caused by circular lists etc., using the above hash tables as required.

* src/comp.c (comp_t): New element symbol_with_pos_sym.
(emit_SYMBOL_WITH_POS_SYM): Amend just to call the new SYMBOL_WITH_POS_SYM.
(emit_CHECK_SYMBOL_WITH_POS, define_SYMBOL_WITH_POS_SYM): New functions.
(Fcomp__init_ctxt): Register an emitter for Qsymbol_with_pos_p.
(Fcomp__compile_ctxt_to_file): Call define_SYMBOL_WITH_POS_SYM.
(syms_of_comp): Define Qsymbol_with_pos_p.

* src/data.c (syms_of_data): Define a new error symbol Qrecursion_error, an
error category for the new error symbols Qexcessive_variable_binding and
Qexcessive_lisp_nesting.

* src/eval.c (grow_specpdl): Change the signal_error call to an xsignal0 call
using the new error symbol Qexcessive_variable_binding.
(eval_sub, Ffuncall): Change the `error' calls to xsignal using the new error
symbol Qexcessive_lisp_nesting.

* src/lread.c (read1): When reading a compiled function, read the components
of the vector without giving its symbols a position.
This commit is contained in:
Alan Mackenzie 2021-12-31 21:21:46 +00:00
parent 1cd188799f
commit ff9af1f1f6
6 changed files with 122 additions and 35 deletions

View file

@ -3576,7 +3576,7 @@ Update all insn accordingly."
;; Symbols imported by C inlined functions. We do this here because
;; is better to add all objs to the relocation containers before we
;; compacting them.
(mapc #'comp-add-const-to-relocs '(nil t consp listp))
(mapc #'comp-add-const-to-relocs '(nil t consp listp symbol-with-pos-p))
(let* ((d-default (comp-ctxt-d-default comp-ctxt))
(d-default-idx (comp-data-container-idx d-default))

View file

@ -32,11 +32,11 @@
;; macros defined by `defmacro'.
(defvar macroexpand-all-environment nil)
(defvar byte-compile--ssp-conses-seen nil
(defvar macroexp--ssp-conses-seen nil
"Which conses have been processed in a strip-symbol-positions operation?")
(defvar byte-compile--ssp-vectors-seen nil
(defvar macroexp--ssp-vectors-seen nil
"Which vectors have been processed in a strip-symbol-positions operation?")
(defvar byte-compile--ssp-records-seen nil
(defvar macroexp--ssp-records-seen nil
"Which records have been processed in a strip-symbol-positions operation?")
(defun macroexp--strip-s-p-2 (arg)
@ -46,8 +46,10 @@ Return the modified ARG."
((symbolp arg)
(bare-symbol arg))
((consp arg)
(unless (memq arg byte-compile--ssp-conses-seen)
;; (push arg byte-compile--ssp-conses-seen)
(unless (and macroexp--ssp-conses-seen
(gethash arg macroexp--ssp-conses-seen))
(if macroexp--ssp-conses-seen
(puthash arg t macroexp--ssp-conses-seen))
(let ((a arg))
(while (consp (cdr a))
(setcar a (macroexp--strip-s-p-2 (car a)))
@ -58,8 +60,10 @@ Return the modified ARG."
(setcdr a (macroexp--strip-s-p-2 (cdr a))))))
arg)
((vectorp arg)
(unless (memq arg byte-compile--ssp-vectors-seen)
(push arg byte-compile--ssp-vectors-seen)
(unless (and macroexp--ssp-vectors-seen
(gethash arg macroexp--ssp-vectors-seen))
(if macroexp--ssp-vectors-seen
(puthash arg t macroexp--ssp-vectors-seen))
(let ((i 0)
(len (length arg)))
(while (< i len)
@ -67,8 +71,10 @@ Return the modified ARG."
(setq i (1+ i)))))
arg)
((recordp arg)
(unless (memq arg byte-compile--ssp-records-seen)
(push arg byte-compile--ssp-records-seen)
(unless (and macroexp--ssp-records-seen
(gethash arg macroexp--ssp-records-seen))
(if macroexp--ssp-records-seen
(puthash arg t macroexp--ssp-records-seen))
(let ((i 0)
(len (length arg)))
(while (< i len)
@ -80,10 +86,18 @@ Return the modified ARG."
(defun byte-compile-strip-s-p-1 (arg)
"Strip all positions from symbols in ARG, destructively modifying ARG.
Return the modified ARG."
(setq byte-compile--ssp-conses-seen nil)
(setq byte-compile--ssp-vectors-seen nil)
(setq byte-compile--ssp-records-seen nil)
(macroexp--strip-s-p-2 arg))
(condition-case err
(progn
(setq macroexp--ssp-conses-seen nil)
(setq macroexp--ssp-vectors-seen nil)
(setq macroexp--ssp-records-seen nil)
(macroexp--strip-s-p-2 arg))
(recursion-error
(dolist (tab '(macroexp--ssp-conses-seen macroexp--ssp-vectors-seen
macroexp--ssp-records-seen))
(set tab (make-hash-table :test 'eq)))
(macroexp--strip-s-p-2 arg))
(error (signal (car err) (cdr err)))))
(defun macroexp-strip-symbol-positions (arg)
"Strip all positions from symbols (recursively) in ARG. Don't modify ARG."