From f687e62ac5dff18a81354e2a29f523c16e3446c3 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Sat, 19 Feb 2022 10:38:19 +0000 Subject: [PATCH] Fix symbols with position appearing in the output of `compile-defun' This happened with the tags of a condition-case. Also fix the detection of circular lists while stripping the positions from symbols with position. * lisp/emacs-lisp/byte-run.el (byte-run--circular-list-p): Remove. (byte-run--strip-s-p-1): Write a value of t into a hash table for each cons or vector/record encountered. (This is to prevent loops with circular structures.) This is now done for all arguments, not just those detected as circular lists. * lisp/emacs-lisp/bytecomp.el (byte-compile-file-form-defvar) (byte-compile-form, byte-compile-dynamic-variable-op) (byte-compile-constant, byte-compile-push-constant): Remove redundant calls to `bare-symbol'. (byte-compile-lambda): call `byte-run-strip-symbol-positions' on the arglist. (byte-compile-out): call `byte-run-strip-symbol-positions' on the operand. This is the main call to this function in bytecomp.el. * src/fns.c (hashfn_eq): Strip the position from an argument which is a symbol with position. (hash_lookup): No longer strip a position from a symbol with position. (sxhash_obj): Add handling for symbols with position, substituting their bare symbols when symbols with position are enabled. --- lisp/emacs-lisp/byte-run.el | 77 +++++++++++++------------------------ lisp/emacs-lisp/bytecomp.el | 28 +++++--------- src/fns.c | 6 ++- 3 files changed, 40 insertions(+), 71 deletions(-) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 110f7e4abf4..5c59d0ae941 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -37,24 +37,6 @@ the corresponding new element of the same type. The purpose of this is to detect circular structures.") -(defalias 'byte-run--circular-list-p - #'(lambda (l) - "Return non-nil when the list L is a circular list. -Note that this algorithm doesn't check any circularity in the -CARs of list elements." - (let ((hare l) - (tortoise l)) - (condition-case err - (progn - (while (progn - (setq hare (cdr (cdr hare)) - tortoise (cdr tortoise)) - (not (or (eq tortoise hare) - (null hare))))) - (eq tortoise hare)) - (wrong-type-argument nil) - (error (signal (car err) (cdr err))))))) - (defalias 'byte-run--strip-s-p-1 #'(lambda (arg) "Strip all positions from symbols in ARG, modifying ARG. @@ -64,41 +46,36 @@ Return the modified ARG." (bare-symbol arg)) ((consp arg) - (let* ((round (byte-run--circular-list-p arg)) - (hash (and round (gethash arg byte-run--ssp-seen)))) - (or hash - (let ((a arg) new) - (while - (progn - (when round - (puthash a new byte-run--ssp-seen)) - (setq new (byte-run--strip-s-p-1 (car a))) - (when (not (eq new (car a))) ; For read-only things. - (setcar a new)) - (and (consp (cdr a)) - (not - (setq hash - (and round - (gethash (cdr a) byte-run--ssp-seen)))))) - (setq a (cdr a))) - (setq new (byte-run--strip-s-p-1 (cdr a))) - (when (not (eq new (cdr a))) - (setcdr a (or hash new))) - arg)))) + (let* ((hash (gethash arg byte-run--ssp-seen))) + (if hash ; Already processed this node. + arg + (let ((a arg) new) + (while + (progn + (puthash a t byte-run--ssp-seen) + (setq new (byte-run--strip-s-p-1 (car a))) + (setcar a new) + (and (consp (cdr a)) + (not + (setq hash (gethash (cdr a) byte-run--ssp-seen))))) + (setq a (cdr a))) + (setq new (byte-run--strip-s-p-1 (cdr a))) + (setcdr a new) + arg)))) ((or (vectorp arg) (recordp arg)) (let ((hash (gethash arg byte-run--ssp-seen))) - (or hash - (let* ((len (length arg)) - (i 0) - new) - (puthash arg arg byte-run--ssp-seen) - (while (< i len) - (setq new (byte-run--strip-s-p-1 (aref arg i))) - (when (not (eq new (aref arg i))) - (aset arg i new)) - (setq i (1+ i))) - arg)))) + (if hash + arg + (let* ((len (length arg)) + (i 0) + new) + (puthash arg t byte-run--ssp-seen) + (while (< i len) + (setq new (byte-run--strip-s-p-1 (aref arg i))) + (aset arg i new) + (setq i (1+ i))) + arg)))) (t arg)))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index ff372151e1b..c59bb292f8f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2610,15 +2610,9 @@ list that represents a doc string reference. nil (byte-compile-docstring-length-warn form) (setq form (copy-sequence form)) - (cond ((consp (nth 2 form)) - (setcar (cdr (cdr form)) - (byte-compile-top-level (nth 2 form) nil 'file))) - ((symbolp (nth 2 form)) - (setcar (cddr form) (bare-symbol (nth 2 form)))) - (t (setcar (cddr form) (nth 2 form)))) - (setcar form (bare-symbol (car form))) - (if (symbolp (nth 1 form)) - (setcar (cdr form) (bare-symbol (nth 1 form)))) + (when (consp (nth 2 form)) + (setcar (cdr (cdr form)) + (byte-compile-top-level (nth 2 form) nil 'file))) form)) (put 'define-abbrev-table 'byte-hunk-handler @@ -3034,7 +3028,8 @@ lambda-expression." (byte-compile-docstring-length-warn fun) (byte-compile-check-lambda-list (nth 1 fun)) (let* ((arglist (nth 1 fun)) - (arglistvars (byte-compile-arglist-vars arglist)) + (arglistvars (byte-run-strip-symbol-positions + (byte-compile-arglist-vars arglist))) (byte-compile-bound-variables (append (if (not lexical-binding) arglistvars) byte-compile-bound-variables)) @@ -3337,12 +3332,10 @@ lambda-expression." (cond ((not (consp form)) (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) - (byte-compile-constant - (if (symbolp form) (bare-symbol form) form))) + (byte-compile-constant form)) ((and byte-compile--for-effect byte-compile-delete-errors) (setq byte-compile--for-effect nil)) - (t - (byte-compile-variable-ref (bare-symbol form))))) + (t (byte-compile-variable-ref form)))) ((symbolp (car form)) (let* ((fn (car form)) (handler (get fn 'byte-compile)) @@ -3572,7 +3565,6 @@ lambda-expression." (byte-compile-warn-obsolete var)))) (defsubst byte-compile-dynamic-variable-op (base-op var) - (if (symbolp var) (setq var (bare-symbol var))) (let ((tmp (assq var byte-compile-variables))) (unless tmp (setq tmp (list var)) @@ -3646,14 +3638,11 @@ assignment (i.e. `setq')." (defun byte-compile-constant (const) (if byte-compile--for-effect (setq byte-compile--for-effect nil) - (inline (byte-compile-push-constant - (if (symbolp const) (bare-symbol const) const))))) + (inline (byte-compile-push-constant const)))) ;; Use this for a constant that is not the value of its containing form. ;; This ignores byte-compile--for-effect. (defun byte-compile-push-constant (const) - (when (symbolp const) - (setq const (bare-symbol const))) (byte-compile-out 'byte-constant (byte-compile-get-constant const))) @@ -5120,6 +5109,7 @@ OP and OPERAND are as passed to `byte-compile-out'." (- 1 operand)))) (defun byte-compile-out (op &optional operand) + (setq operand (byte-run-strip-symbol-positions operand)) (push (cons op operand) byte-compile-output) (if (eq op 'byte-return) ;; This is actually an unnecessary case, because there should be no diff --git a/src/fns.c b/src/fns.c index ea8428fd98d..06a64563806 100644 --- a/src/fns.c +++ b/src/fns.c @@ -4265,6 +4265,8 @@ cmpfn_user_defined (Lisp_Object key1, Lisp_Object key2, static Lisp_Object hashfn_eq (Lisp_Object key, struct Lisp_Hash_Table *h) { + if (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (key)) + key = SYMBOL_WITH_POS_SYM (key); return make_ufixnum (XHASH (key) ^ XTYPE (key)); } @@ -4543,8 +4545,6 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object *hash) ptrdiff_t start_of_bucket, i; Lisp_Object hash_code; - if (SYMBOL_WITH_POS_P (key)) - key = SYMBOL_WITH_POS_SYM (key); hash_code = h->test.hashfn (key, h); if (hash) *hash = hash_code; @@ -4982,6 +4982,8 @@ sxhash_obj (Lisp_Object obj, int depth) hash = sxhash_combine (hash, sxhash_obj (XOVERLAY (obj)->plist, depth)); return SXHASH_REDUCE (hash); } + else if (symbols_with_pos_enabled && pvec_type == PVEC_SYMBOL_WITH_POS) + return sxhash_obj (XSYMBOL_WITH_POS (obj)->sym, depth + 1); else /* Others are 'equal' if they are 'eq', so take their address as hash. */ -- 2.39.5