master f687e62ac5: Fix symbols with position appearing in the output of `compile-defun'

[Alan Mackenzie]

branch: master
commit f687e62ac5dff18a81354e2a29f523c16e3446c3
Author: Alan Mackenzie <acm@muc.de>
Commit: Alan Mackenzie <acm@muc.de>

    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 110f7e4abf..5c59d0ae94 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 ff372151e1..c59bb292f8 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 ea8428fd98..06a6456380 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.  */