First commit of scratch/correct-warning-pos.

This branch is intended to generate correct position information in warning
and error messages from the byte compiler, and is intended thereby to fix bugs

It introduces a new mechanism, the symbol with position.  This is taken over
from the previous git branch scratch/accurate-warning-pos which was abandoned
for being too slow.  The main difference in the current branch is that the
symbol `nil' is never given a position, thus speeding up NILP markedly.

* lisp/emacs-lisp/byte-opt.el (byte-compile-inline-expand)
(byte-optimize-form-code-walker, byte-optimize-let-form, byte-optimize-while)
(byte-optimize-apply): Use byte-compile-warn-x in place of byte-compile-warn.

* lisp/emacs-lisp/bytecomp.el (byte-compile--form-stack): New variable.
(byte-compile-strip-s-p-1, byte-compile-strip-symbol-positions): New
functions.
(byte-compile-recurse-toplevel, byte-compile-initial-macro-environment)
(byte-compile-preprocess, byte-compile-macroexpand-declare-function): Bind
print-symbols-bare to non-nil.
(byte-compile--first-symbol, byte-compile--warning-source-offset): New
functions.
(byte-compile-warning-prefix): Modify to output two sets of position
information, the old (incorrect) set and the new set.
(byte-compile-warn): Strip positions from symbols before outputting.
(byte-compile-warn-x): New function which outputs a correct position supplied
in an argument.
(byte-compile-warn-obsolete, byte-compile-emit-callargs-warn)
(byte-compile-format-warn, byte-compile-nogroup-warn)
(byte-compile-arglist-warn, byte-compile-docstring-length-warn)
(byte-compile-warn-about-unresolved-functions, byte-compile-file)
(byte-compile--check-prefixed-var, byte-compile--declare-var)
(byte-compile-file-form-defvar-function, byte-compile-file-form-defmumble)
(byte-compile-check-lambda-list, byte-compile--warn-lexical-dynamic)
(byte-compile-lambda, byte-compile-form, byte-compile-normal-call)
(byte-compile-check-variable, byte-compile-free-vars-warn)
(byte-compile-subr-wrong-args, byte-compile-fset, byte-compile-set-default)
(byte-compile-condition-case, byte-compile-save-excursion)
(byte-compile-defvar, byte-compile-autoload)
(byte-compile-make-variable-buffer-local, byte-compile-define-symbol-prop)
(byte-compile-define-keymap): Replace byte-compile-warn with
byte-compile-warn-x.
(byte-compile-file, compile-defun): Bind symbols-with-pos-enabled to non-nil.
(compile-defun, byte-compile-from-buffer): Use `read-positioning-symbols'
rather than plain `read'.
(byte-compile-toplevel-file-form, byte-compile-form): Dynamically bind
byte-compile--form-stack.
(byte-compile-file-form-autoload, byte-compile-file-form-defvar)
(byte-compile-file-form-make-obsolete, byte-compile-lambda)
(byte-compile-push-constant, byte-compile-cond-jump-table)
(byte-compile-define-keymap, byte-compile-annotate-call-tree):
Strip positions from symbols where they are unwanted.
(byte-compile-file-form-defvar): Strip positions from symbols using
`bare-symbol'.
(byte-compile-file-form-defmumble): New variable bare-name, a version of name
without its position.
(byte-compile-lambda): Similarly, new variable bare-arglist.
(byte-compile-free-vars-warn): New argument arg supplying position information
to byte-compile-warn-x.
(byte-compile-push-constant): Manipulation of symbol positions.
(display-call-tree): Strip positions from symbols.

* lisp/emacs-lisp/cconv.el (cconv-convert, cconv--analyze-use)
(cconv--analyze-function, cconv-analyze-form): Replace use of
byte-compile-warn with byte-compile-warn-x.

* lisp/emacs-lisp/cl-generic.el (cl-defmethod): New variable org-name which
  will supply position information to a new macroexp-warn-and-return.

  * lisp/emacs-lisp/cl-macs.el (cl-macs--strip-s-p-1)
  (cl-macs--strip-symbol-positions): New functions to strip positions from
  symbols in an expression.  These duplicaate similarly named functions in
  bytecomp.el.

  * lisp/emacs-lisp/macroexpand.el (macroexp--warn-wrap): Calls
  byte-compile-warn-x in place of byte-compile-warn.
  (macroexp-warn-and-return): Commented out new position parameter _arg.

* src/.gdbinit: Add in code to handle symbols with position.

* src/alloc.c (XPNTR, set_symbol_name, valid_lisp_object_p, purecopy)
(mark_char_table, mark_object, survives_gc_p, symbol_uses_obj): Use
BARE_SYMBOL_P and XBARE_SYMBOL in place of the former SYMBOLP and XSYMBOL.
(build_symbol_with_pos): New function.
(Fgarbage_collect): Bind Qsymbols_with_pos_enabled to nil around the call to
garbage_collect.

* src/data.c (Ftype_of): Add case for PVEC_SYMBOL_WITH_POS.
(Fbare_symbol_p, Fsymbol_with_pos_p, Fbare_symbol, Fsymbol_with_pos_pos)
(Fposition_symbol): New functions.
(symbols_with_pos_enabled): New boolean variable.

* src/fns.c (internal_equal, hash_lookup): Handle symbols with position.

* src/keyboard.c (recursive_edit_1): Bind Qsymbols_with_pos_enabled and
Qprint_symbols_bare to nil.

* src/lisp.h (lisp_h_PSEUDOVECTORP): New macro.
(lisp_h_BASE_EQ): New name for the former lisp_h_EQ.
(lisp_h_EQ): Extended to handle symbols with position.
(lisp_h_NILP): Now uses BASE_EQ rather than EQ.
(lisp_h_SYMBOL_WITH_POS_P, lisp_h_BARE_SYMBOL_P): New macros.
(lisp_h_SYMBOLP): Redefined to handle symbols with position.
(BARE_SYMBOL_P, BASE_EQ): New macros.
(SYMBOLP (macro)): Removed.
(SYMBOLP (function), XSYMBOL, make_lisp_symbol, builtin_lisp_symbol)
(c_symbol_p): Moved to later in file.
(struct Lisp_Symbol_With_Pos): New data type.
(pvec_type): PVEC_SYMBOL_WITH_POS: New type code.
(PSEUDOVECTORP): Redefined to use the lisp_h_PSEUDOVECTORP.
(BARE_SYMBOL_P, SYMBOL_WITH_POS_P, SYMBOLP, XSYMBOL_WITH_POS, XBARE_SYMBOL)
(XSYMBOL, make_lisp_symbol, builtin_lisp_symbol, c_symbol_p, CHECK_SYMBOL)
(BASE_EQ): New functions, or functions moved from earlier in the file.
(SYMBOL_WITH_POS_SYM, SYMBOL_WITH_POS_POS): New INLINE functions.

* src/lread.c (read0, read1, read_list, read_vector, read_internal_start)
(list2): Add a new bool parameter locate_syms.
(Fread_positioning_symbols): New function.
(Fread_from_string, read_internal_start, read0, read1, read_list): Pass around
suitable values for locate_syms.
(read1): Build symbols with position when locate_syms is true.

* src/print.c (print_vectorlike): Add handling for PVEC_SYMBOL_WITH_POS.
(print_object): Replace EQ with BASE_EQ.
(print_symbols_bare): New boolean variable.

1 files changed, 85 insertions, 41 deletions

diff --git a/src/lread.c b/src/lread.c
index 2e63ec48912..7775911c1d3 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -647,12 +647,12 @@ struct subst
 };
 
 static Lisp_Object read_internal_start (Lisp_Object, Lisp_Object,
-                                        Lisp_Object);
-static Lisp_Object read0 (Lisp_Object);
-static Lisp_Object read1 (Lisp_Object, int *, bool);
+                                        Lisp_Object, bool);
+static Lisp_Object read0 (Lisp_Object, bool);
+static Lisp_Object read1 (Lisp_Object, int *, bool, bool);
 
-static Lisp_Object read_list (bool, Lisp_Object);
-static Lisp_Object read_vector (Lisp_Object, bool);
+static Lisp_Object read_list (bool, Lisp_Object, bool);
+static Lisp_Object read_vector (Lisp_Object, bool, bool);
 
 static Lisp_Object substitute_object_recurse (struct subst *, Lisp_Object);
 static void substitute_in_interval (INTERVAL, void *);
@@ -2280,7 +2280,7 @@ readevalloop (Lisp_Object readcharfun,
 			     Qnil, false);
       if (!NILP (Vpurify_flag) && c == '(')
 	{
-	  val = read_list (0, readcharfun);
+	  val = read_list (0, readcharfun, false);
 	}
       else
 	{
@@ -2302,7 +2302,7 @@ readevalloop (Lisp_Object readcharfun,
 	  else if (! NILP (Vload_read_function))
 	    val = call1 (Vload_read_function, readcharfun);
 	  else
-	    val = read_internal_start (readcharfun, Qnil, Qnil);
+	    val = read_internal_start (readcharfun, Qnil, Qnil, false);
 	}
       /* Empty hashes can be reused; otherwise, reset on next call.  */
       if (HASH_TABLE_P (read_objects_map)
@@ -2460,7 +2460,35 @@ STREAM or the value of `standard-input' may be:
     return call1 (intern ("read-minibuffer"),
 		  build_string ("Lisp expression: "));
 
-  return read_internal_start (stream, Qnil, Qnil);
+  return read_internal_start (stream, Qnil, Qnil, false);
+}
+
+DEFUN ("read-positioning-symbols", Fread_positioning_symbols,
+       Sread_positioning_symbols, 0, 1, 0,
+       doc: /* Read one Lisp expression as text from STREAM, return as Lisp object.
+Convert each occurrence of a symbol into a "symbol with pos" object.
+
+If STREAM is nil, use the value of `standard-input' (which see).
+STREAM or the value of `standard-input' may be:
+ a buffer (read from point and advance it)
+ a marker (read from where it points and advance it)
+ a function (call it with no arguments for each character,
+     call it with a char as argument to push a char back)
+ a string (takes text from string, starting at the beginning)
+ t (read text line using minibuffer and use it, or read from
+    standard input in batch mode).  */)
+  (Lisp_Object stream)
+{
+  if (NILP (stream))
+    stream = Vstandard_input;
+  if (EQ (stream, Qt))
+    stream = Qread_char;
+  if (EQ (stream, Qread_char))
+    /* FIXME: ?! When is this used !?  */
+    return call1 (intern ("read-minibuffer"),
+		  build_string ("Lisp expression: "));
+
+  return read_internal_start (stream, Qnil, Qnil, true);
 }
 
 DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
@@ -2476,14 +2504,17 @@ the end of STRING.  */)
   Lisp_Object ret;
   CHECK_STRING (string);
   /* `read_internal_start' sets `read_from_string_index'.  */
-  ret = read_internal_start (string, start, end);
+  ret = read_internal_start (string, start, end, false);
   return Fcons (ret, make_fixnum (read_from_string_index));
 }
 
 /* Function to set up the global context we need in toplevel read
-   calls.  START and END only used when STREAM is a string.  */
+   calls.  START and END only used when STREAM is a string.
+   LOCATE_SYMS true means read symbol occurrences as symbols with
+   position.  */
 static Lisp_Object
-read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end)
+read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end,
+                     bool locate_syms)
 {
   Lisp_Object retval;
 
@@ -2523,7 +2554,7 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end)
       read_from_string_limit = endval;
     }
 
-  retval = read0 (stream);
+  retval = read0 (stream, locate_syms);
   if (EQ (Vread_with_symbol_positions, Qt)
       || EQ (Vread_with_symbol_positions, stream))
     Vread_symbol_positions_list = Fnreverse (Vread_symbol_positions_list);
@@ -2542,12 +2573,12 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end)
    are not allowed.  */
 
 static Lisp_Object
-read0 (Lisp_Object readcharfun)
+read0 (Lisp_Object readcharfun, bool locate_syms)
 {
   register Lisp_Object val;
   int c;
 
-  val = read1 (readcharfun, &c, 0);
+  val = read1 (readcharfun, &c, 0, locate_syms);
   if (!c)
     return val;
 
@@ -2971,10 +3002,12 @@ read_integer (Lisp_Object readcharfun, int radix,
    in *PCH and the return value is not interesting.  Else, we store
    zero in *PCH and we read and return one lisp object.
 
-   FIRST_IN_LIST is true if this is the first element of a list.  */
+   FIRST_IN_LIST is true if this is the first element of a list.
+   LOCATE_SYMS true means read symbol occurrences as symbols with
+   position.  */
 
 static Lisp_Object
-read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
+read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms)
 {
   int c;
   bool uninterned_symbol = false;
@@ -2994,10 +3027,10 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
   switch (c)
     {
     case '(':
-      return read_list (0, readcharfun);
+      return read_list (0, readcharfun, locate_syms);
 
     case '[':
-      return read_vector (readcharfun, 0);
+      return read_vector (readcharfun, 0, locate_syms);
 
     case ')':
     case ']':
@@ -3016,7 +3049,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
 	      /* Accept extended format for hash tables (extensible to
 		 other types), e.g.
 		 #s(hash-table size 2 test equal data (k1 v1 k2 v2))  */
-	      Lisp_Object tmp = read_list (0, readcharfun);
+	      Lisp_Object tmp = read_list (0, readcharfun, false);
 	      Lisp_Object head = CAR_SAFE (tmp);
 	      Lisp_Object data = Qnil;
 	      Lisp_Object val = Qnil;
@@ -3105,7 +3138,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
 	  if (c == '[')
 	    {
 	      Lisp_Object tmp;
-	      tmp = read_vector (readcharfun, 0);
+	      tmp = read_vector (readcharfun, 0, false);
 	      if (ASIZE (tmp) < CHAR_TABLE_STANDARD_SLOTS)
 		error ("Invalid size char-table");
 	      XSETPVECTYPE (XVECTOR (tmp), PVEC_CHAR_TABLE);
@@ -3118,7 +3151,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
 		{
 		  /* Sub char-table can't be read as a regular
 		     vector because of a two C integer fields.  */
-		  Lisp_Object tbl, tmp = read_list (1, readcharfun);
+		  Lisp_Object tbl, tmp = read_list (1, readcharfun, false);
 		  ptrdiff_t size = list_length (tmp);
 		  int i, depth, min_char;
 		  struct Lisp_Cons *cell;
@@ -3156,7 +3189,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
       if (c == '&')
 	{
 	  Lisp_Object length;
-	  length = read1 (readcharfun, pch, first_in_list);
+	  length = read1 (readcharfun, pch, first_in_list, false);
 	  c = READCHAR;
 	  if (c == '"')
 	    {
@@ -3165,7 +3198,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
 	      unsigned char *data;
 
 	      UNREAD (c);
-	      tmp = read1 (readcharfun, pch, first_in_list);
+	      tmp = read1 (readcharfun, pch, first_in_list, false);
 	      if (STRING_MULTIBYTE (tmp)
 		  || (size_in_chars != SCHARS (tmp)
 		      /* We used to print 1 char too many
@@ -3193,7 +3226,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
 	     build them using function calls.  */
 	  Lisp_Object tmp;
 	  struct Lisp_Vector *vec;
-	  tmp = read_vector (readcharfun, 1);
+	  tmp = read_vector (readcharfun, 1, locate_syms);
 	  vec = XVECTOR (tmp);
 	  if (! (COMPILED_STACK_DEPTH < ASIZE (tmp)
 		 && (FIXNUMP (AREF (tmp, COMPILED_ARGLIST))
@@ -3243,7 +3276,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
 	  int ch;
 
 	  /* Read the string itself.  */
-	  tmp = read1 (readcharfun, &ch, 0);
+	  tmp = read1 (readcharfun, &ch, 0, false);
 	  if (ch != 0 || !STRINGP (tmp))
 	    invalid_syntax ("#", readcharfun);
 	  /* Read the intervals and their properties.  */
@@ -3251,14 +3284,14 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
 	    {
 	      Lisp_Object beg, end, plist;
 
-	      beg = read1 (readcharfun, &ch, 0);
+	      beg = read1 (readcharfun, &ch, 0, false);
 	      end = plist = Qnil;
 	      if (ch == ')')
 		break;
 	      if (ch == 0)
-		end = read1 (readcharfun, &ch, 0);
+		end = read1 (readcharfun, &ch, 0, false);
 	      if (ch == 0)
-		plist = read1 (readcharfun, &ch, 0);
+		plist = read1 (readcharfun, &ch, 0, false);
 	      if (ch)
 		invalid_syntax ("Invalid string property list", readcharfun);
 	      Fset_text_properties (beg, end, plist, tmp);
@@ -3369,7 +3402,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
       if (c == '$')
 	return Vload_file_name;
       if (c == '\'')
-	return list2 (Qfunction, read0 (readcharfun));
+	return list2 (Qfunction, read0 (readcharfun, locate_syms));
       /* #:foo is the uninterned symbol named foo.  */
       if (c == ':')
 	{
@@ -3452,7 +3485,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
 			hash_put (h, number, placeholder, hash);
 
 		      /* Read the object itself.  */
-		      Lisp_Object tem = read0 (readcharfun);
+		      Lisp_Object tem = read0 (readcharfun, locate_syms);
 
 		      /* If it can be recursive, remember it for
 			 future substitutions.  */
@@ -3508,6 +3541,9 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
       else if (c == 'b' || c == 'B')
 	return read_integer (readcharfun, 2, stackbuf);
 
+      char acm_buf[15];		/* FIXME!!! 2021-11-27. */
+      sprintf (acm_buf, "#%c", c);
+      invalid_syntax (acm_buf, readcharfun);
       UNREAD (c);
       invalid_syntax ("#", readcharfun);
 
@@ -3516,10 +3552,10 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
       goto retry;
 
     case '\'':
-      return list2 (Qquote, read0 (readcharfun));
+      return list2 (Qquote, read0 (readcharfun, locate_syms));
 
     case '`':
-      return list2 (Qbackquote, read0 (readcharfun));
+      return list2 (Qbackquote, read0 (readcharfun, locate_syms));
 
     case ',':
       {
@@ -3535,7 +3571,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
 	    comma_type = Qcomma;
 	  }
 
-	value = read0 (readcharfun);
+	value = read0 (readcharfun, locate_syms);
 	return list2 (comma_type, value);
       }
     case '?':
@@ -3842,6 +3878,11 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list)
 		  result = intern_driver (name, obarray, tem);
 		}
 	    }
+	  if (locate_syms
+	      && !NILP (result)
+	      )
+	    result = build_symbol_with_pos (result,
+					    make_fixnum (start_position));
 
 	  if (EQ (Vread_with_symbol_positions, Qt)
 	      || EQ (Vread_with_symbol_positions, readcharfun))
@@ -4100,9 +4141,9 @@ string_to_number (char const *string, int base, ptrdiff_t *plen)
 
 
 static Lisp_Object
-read_vector (Lisp_Object readcharfun, bool bytecodeflag)
+read_vector (Lisp_Object readcharfun, bool bytecodeflag, bool locate_syms)
 {
-  Lisp_Object tem = read_list (1, readcharfun);
+  Lisp_Object tem = read_list (1, readcharfun, locate_syms);
   ptrdiff_t size = list_length (tem);
   Lisp_Object vector = make_nil_vector (size);
 
@@ -4174,10 +4215,12 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag)
   return vector;
 }
 
-/* FLAG means check for ']' to terminate rather than ')' and '.'.  */
+/* FLAG means check for ']' to terminate rather than ')' and '.'.
+   LOCATE_SYMS true means read symbol occurrencess as symbols with
+   position. */
 
 static Lisp_Object
-read_list (bool flag, Lisp_Object readcharfun)
+read_list (bool flag, Lisp_Object readcharfun, bool locate_syms)
 {
   Lisp_Object val, tail;
   Lisp_Object elt, tem;
@@ -4195,7 +4238,7 @@ read_list (bool flag, Lisp_Object readcharfun)
   while (1)
     {
       int ch;
-      elt = read1 (readcharfun, &ch, first_in_list);
+      elt = read1 (readcharfun, &ch, first_in_list, locate_syms);
 
       first_in_list = 0;
 
@@ -4239,10 +4282,10 @@ read_list (bool flag, Lisp_Object readcharfun)
 	  if (ch == '.')
 	    {
 	      if (!NILP (tail))
-		XSETCDR (tail, read0 (readcharfun));
+		XSETCDR (tail, read0 (readcharfun, locate_syms));
 	      else
-		val = read0 (readcharfun);
-	      read1 (readcharfun, &ch, 0);
+		val = read0 (readcharfun, locate_syms);
+	      read1 (readcharfun, &ch, 0, locate_syms);
 
 	      if (ch == ')')
 		{
@@ -5120,6 +5163,7 @@ void
 syms_of_lread (void)
 {
   defsubr (&Sread);
+  defsubr (&Sread_positioning_symbols);
   defsubr (&Sread_from_string);
   defsubr (&Slread__substitute_object_in_subtree);
   defsubr (&Sintern);