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.

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 8581fe80662f2c91ed0c8fa8f3437cc6afc903b4..1912d0d0037cf7413347f30a3bf91cd35c2684f4 100644 (file)
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -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))

diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index dafd5497639f60367fb0eaba5fb9ccb40c42b2f5..11204f7f7fb05ac304f64691812dad0a91b77a63 100644 (file)
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -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."

diff --git a/src/comp.c b/src/comp.c
index ac38c2131f9ea5d21563db41e50a949fb91336df..834656897e4c8d0c414d6c09a45a92dadc623dae 100644 (file)
--- a/src/comp.c
+++ b/src/comp.c
@@ -574,6 +574,7 @@ typedef struct {
   gcc_jit_type *lisp_symbol_with_position_type;
   gcc_jit_type *lisp_symbol_with_position_ptr_type;
   gcc_jit_function *get_symbol_with_position;
+  gcc_jit_function *symbol_with_pos_sym;
   /* struct jmp_buf.  */
   gcc_jit_struct *jmp_buf_s;
   /* struct handler.  */
@@ -1475,21 +1476,12 @@ emit_SYMBOL_WITH_POS_SYM (gcc_jit_rvalue *obj)
 {
   emit_comment ("SYMBOL_WITH_POS_SYM");
 
-  gcc_jit_rvalue *tmp2, *swp;
-  gcc_jit_lvalue *tmpl;
-
-  gcc_jit_rvalue *args[] = { obj };
-  swp = gcc_jit_context_new_call (comp.ctxt,
-                                 NULL,
-                                 comp.get_symbol_with_position,
-                                 1,
-                                 args);
-  tmpl = gcc_jit_rvalue_dereference (swp, gcc_jit_context_new_location (comp.ctxt, "comp.c", __LINE__, 0));
-  tmp2 = gcc_jit_lvalue_as_rvalue (tmpl);
-  return
-    gcc_jit_rvalue_access_field (tmp2,
-                                NULL,
-                                comp.lisp_symbol_with_position_sym);
+  gcc_jit_rvalue *arg [] = { obj };
+  return gcc_jit_context_new_call (comp.ctxt,
+                                  NULL,
+                                  comp.symbol_with_pos_sym,
+                                  1,
+                                  arg);
 }
 
 static gcc_jit_rvalue *
@@ -1858,6 +1850,29 @@ emit_CHECK_CONS (gcc_jit_rvalue *x)
                              args));
 }
 
+static void
+emit_CHECK_SYMBOL_WITH_POS (gcc_jit_rvalue *x)
+{
+  emit_comment ("CHECK_SYMBOL_WITH_POS");
+
+  gcc_jit_rvalue *args[] =
+    { gcc_jit_context_new_cast (comp.ctxt,
+                               NULL,
+                               emit_SYMBOL_WITH_POS_P (x),
+                               comp.int_type),
+      emit_lisp_obj_rval (Qsymbol_with_pos_p),
+      x };
+
+  gcc_jit_block_add_eval (
+    comp.block,
+    NULL,
+    gcc_jit_context_new_call (comp.ctxt,
+                             NULL,
+                             comp.check_type,
+                             3,
+                             args));
+}
+
 static gcc_jit_rvalue *
 emit_car_addr (gcc_jit_rvalue *c)
 {
@@ -3886,6 +3901,48 @@ define_GET_SYMBOL_WITH_POSITION (void)
               1, args, false));
 }
 
+static void define_SYMBOL_WITH_POS_SYM (void)
+{
+  gcc_jit_rvalue *tmpr, *swp;
+  gcc_jit_lvalue *tmpl;
+
+  gcc_jit_param *param [] =
+    { gcc_jit_context_new_param (comp.ctxt,
+                                NULL,
+                                comp.lisp_obj_type,
+                                "a") };
+  comp.symbol_with_pos_sym =
+    gcc_jit_context_new_function (comp.ctxt, NULL,
+                                 GCC_JIT_FUNCTION_INTERNAL,
+                                 comp.lisp_obj_type,
+                                 "SYMBOL_WITH_POS_SYM",
+                                 1,
+                                 param,
+                                 0);
+
+  DECL_BLOCK (entry_block, comp.symbol_with_pos_sym);
+  comp.func = comp.symbol_with_pos_sym;
+  comp.block = entry_block;
+
+  emit_CHECK_SYMBOL_WITH_POS (gcc_jit_param_as_rvalue (param [0]));
+
+  gcc_jit_rvalue *args[] = { gcc_jit_param_as_rvalue (param [0]) };
+
+  swp = gcc_jit_context_new_call (comp.ctxt,
+                                 NULL,
+                                 comp.get_symbol_with_position,
+                                 1,
+                                 args);
+  tmpl = gcc_jit_rvalue_dereference (swp, NULL);
+  tmpr = gcc_jit_lvalue_as_rvalue (tmpl);
+  gcc_jit_block_end_with_return (entry_block,
+                                NULL,
+                                gcc_jit_rvalue_access_field (
+                                  tmpr,
+                                  NULL,
+                                  comp.lisp_symbol_with_position_sym));
+}
+
 static void
 define_CHECK_IMPURE (void)
 {
@@ -4504,6 +4561,7 @@ Return t on success.  */)
       register_emitter (Qnumberp, emit_numperp);
       register_emitter (Qintegerp, emit_integerp);
       register_emitter (Qcomp_maybe_gc_or_quit, emit_maybe_gc_or_quit);
+      register_emitter (Qsymbol_with_pos_p, emit_SYMBOL_WITH_POS_P);
     }
 
   comp.ctxt = gcc_jit_context_acquire ();
@@ -4820,6 +4878,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file,
   define_PSEUDOVECTORP ();
   define_GET_SYMBOL_WITH_POSITION ();
   define_CHECK_TYPE ();
+  define_SYMBOL_WITH_POS_SYM ();
   define_CHECK_IMPURE ();
   define_bool_to_lisp_obj ();
   define_setcar_setcdr ();
@@ -5618,6 +5677,7 @@ compiled one.  */);
   DEFSYM (Qnumberp, "numberp");
   DEFSYM (Qintegerp, "integerp");
   DEFSYM (Qcomp_maybe_gc_or_quit, "comp-maybe-gc-or-quit");
+  DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p");
 
   /* Allocation classes. */
   DEFSYM (Qd_default, "d-default");

diff --git a/src/data.c b/src/data.c
index 1f2af6f474351005b21a4671edad0f4f33adf43f..6d9c0aef93327879ed76e43ff4f9b706fdcee704 100644 (file)
--- a/src/data.c
+++ b/src/data.c
@@ -3969,7 +3969,7 @@ A is a bool vector, B is t or nil, and I is an index into A.  */)
 void
 syms_of_data (void)
 {
-  Lisp_Object error_tail, arith_tail;
+  Lisp_Object error_tail, arith_tail, recursion_tail;
 
   DEFSYM (Qquote, "quote");
   DEFSYM (Qlambda, "lambda");
@@ -4004,6 +4004,10 @@ syms_of_data (void)
   DEFSYM (Qmark_inactive, "mark-inactive");
   DEFSYM (Qinhibited_interaction, "inhibited-interaction");
 
+  DEFSYM (Qrecursion_error, "recursion-error");
+  DEFSYM (Qexcessive_variable_binding, "excessive-variable-binding");
+  DEFSYM (Qexcessive_lisp_nesting, "excessive-lisp-nesting");
+
   DEFSYM (Qlistp, "listp");
   DEFSYM (Qconsp, "consp");
   DEFSYM (Qbare_symbol_p, "bare-symbol-p");
@@ -4112,6 +4116,16 @@ syms_of_data (void)
   PUT_ERROR (Qunderflow_error, Fcons (Qrange_error, arith_tail),
             "Arithmetic underflow error");
 
+  recursion_tail = pure_cons (Qrecursion_error, error_tail);
+  Fput (Qrecursion_error, Qerror_conditions, recursion_tail);
+  Fput (Qrecursion_error, Qerror_message, build_pure_c_string
+       ("Excessive recursive calling error"));
+
+  PUT_ERROR (Qexcessive_variable_binding, recursion_tail,
+            "Variable binding depth exceeds max-specpdl-size");
+  PUT_ERROR (Qexcessive_lisp_nesting, recursion_tail,
+            "Lisp nesting exceeds `max-lisp-eval-depth'");
+
   /* Types that type-of returns.  */
   DEFSYM (Qinteger, "integer");
   DEFSYM (Qsymbol, "symbol");

diff --git a/src/eval.c b/src/eval.c
index 94ad060773281acb2a1298b8a6290a45855e77a3..5cb673ab223a5d09c3e37816cb3fcdc072251eee 100644 (file)
--- a/src/eval.c
+++ b/src/eval.c
@@ -2398,8 +2398,7 @@ grow_specpdl (void)
          if (max_specpdl_size < 400)
            max_size = max_specpdl_size = 400;
          if (max_size <= specpdl_size)
-           signal_error ("Variable binding depth exceeds max-specpdl-size",
-                         Qnil);
+           xsignal0 (Qexcessive_variable_binding);
        }
       pdlvec = xpalloc (pdlvec, &pdlvecsize, 1, max_size + 1, sizeof *specpdl);
       specpdl = pdlvec + 1;
@@ -2453,7 +2452,7 @@ eval_sub (Lisp_Object form)
       if (max_lisp_eval_depth < 100)
        max_lisp_eval_depth = 100;
       if (lisp_eval_depth > max_lisp_eval_depth)
-       error ("Lisp nesting exceeds `max-lisp-eval-depth'");
+       xsignal0 (Qexcessive_lisp_nesting);
     }
 
   Lisp_Object original_fun = XCAR (form);
@@ -3044,7 +3043,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS)  */)
       if (max_lisp_eval_depth < 100)
        max_lisp_eval_depth = 100;
       if (lisp_eval_depth > max_lisp_eval_depth)
-       error ("Lisp nesting exceeds `max-lisp-eval-depth'");
+       xsignal0 (Qexcessive_lisp_nesting);
     }
 
   count = record_in_backtrace (args[0], &args[1], nargs - 1);

diff --git a/src/lread.c b/src/lread.c
index 1cc5acc6d3a8169e9a05801adc2869a5bf1d8593..835228439f182139fba032dc67a217c2a51aa187 100644 (file)
--- a/src/lread.c
+++ b/src/lread.c
@@ -3225,7 +3225,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms)
             build them using function calls.  */
          Lisp_Object tmp;
          struct Lisp_Vector *vec;
-         tmp = read_vector (readcharfun, 1, locate_syms);
+         tmp = read_vector (readcharfun, 1, false);
          vec = XVECTOR (tmp);
          if (! (COMPILED_STACK_DEPTH < ASIZE (tmp)
                 && (FIXNUMP (AREF (tmp, COMPILED_ARGLIST))