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
parent
1cd188799f
commit
ff9af1f1f6
6 changed files with 122 additions and 35 deletions
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
90
src/comp.c
90
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");
|
||||
|
|
|
|||
16
src/data.c
16
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");
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue