From c578c72aae601462a5ece8cc15aa6d13bc80e196 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 8 May 2020 09:28:01 +0100 Subject: Add function lexspace contex mechanism --- src/alloc.c | 4 ++-- src/emacs.c | 2 +- src/eval.c | 43 +++++++++++++++++++++++++++++++++++++++++-- src/lexspaces.c | 17 +++++++++-------- src/lisp.h | 22 +++++++++++----------- 5 files changed, 64 insertions(+), 24 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index 5199238b6bf..1ab96a72218 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -7006,8 +7006,8 @@ sweep_symbols (void) symbol_free_list = sym; /* FIXME */ if (!NILP (sym->u.s._function)) - XBINDING (symbol_free_list->u.s._function)->b[curr_lexspace] = - dead_object (); + XBINDING (symbol_free_list->u.s._function)->b[CURRENT_LEXSPACE] + = dead_object (); ++this_free; } else diff --git a/src/emacs.c b/src/emacs.c index a826a60adcf..38798ee0f5e 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -957,7 +957,7 @@ main (int argc, char **argv) #ifdef HAVE_PDUMPER bool attempt_load_pdump = false; #endif - + Vcurrent_lexspace_idx = make_fixnum (0); /* Look for this argument first, before any heap allocation, so we can set heap flags properly if we're going to unexec. */ if (!initialized && temacs) diff --git a/src/eval.c b/src/eval.c index 7e2fbca743a..2bf8dcb0f79 100644 --- a/src/eval.c +++ b/src/eval.c @@ -64,6 +64,7 @@ union specbinding *backtrace_next (union specbinding *) EXTERNALLY_VISIBLE; union specbinding *backtrace_top (void) EXTERNALLY_VISIBLE; static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *); +static Lisp_Object apply_lambda0 (Lisp_Object, Lisp_Object, ptrdiff_t); static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, ptrdiff_t); static Lisp_Object lambda_arity (Lisp_Object); @@ -2159,6 +2160,7 @@ record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs) Lisp_Object eval_sub (Lisp_Object form) { + Lisp_Object lexspace = Qnil; if (SYMBOLP (form)) { /* Look up its binding in the lexical environment. @@ -2208,7 +2210,10 @@ eval_sub (Lisp_Object form) fun = original_fun; if (!SYMBOLP (fun)) fun = Ffunction (list1 (fun)); - else if (!NILP (fun) && (fun = SYMBOL_FUNCTION (XSYMBOL (fun)), SYMBOLP (fun))) + else if (!NILP (fun) + && (lexspace = SYMBOL_FUNC_LEXSPACE (XSYMBOL (fun)), + SYMBOL_FUNCTION (XSYMBOL (fun)), + SYMBOLP (fun))) fun = indirect_function (fun); if (SUBRP (fun)) @@ -2345,7 +2350,19 @@ eval_sub (Lisp_Object form) } else if (EQ (funcar, Qlambda) || EQ (funcar, Qclosure)) - return apply_lambda (fun, original_args, count); + { + if (!NILP (lexspace) + && !EQ (lexspace, Vcurrent_lexspace_idx)) + { + ptrdiff_t count1 = SPECPDL_INDEX (); + specbind (Qcurrent_lexspace_idx, lexspace); + return unbind_to (count1, + apply_lambda0 (fun, original_args, + SPECPDL_INDEX ())); + } + return apply_lambda (fun, original_args, count); + } + else xsignal1 (Qinvalid_function, original_fun); } @@ -2904,6 +2921,28 @@ funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args) } } +static Lisp_Object +apply_lambda0 (Lisp_Object fun, Lisp_Object args, ptrdiff_t count) +{ + Lisp_Object *arg_vector; + Lisp_Object tem; + USE_SAFE_ALLOCA; + + ptrdiff_t numargs = list_length (args); + SAFE_ALLOCA_LISP (arg_vector, numargs); + Lisp_Object args_left = args; + + for (ptrdiff_t i = 0; i < numargs; i++) + { + tem = Fcar (args_left), args_left = Fcdr (args_left); + tem = eval_sub (tem); + arg_vector[i] = tem; + } + tem = funcall_lambda (fun, numargs, arg_vector); + SAFE_FREE (); + return tem; +} + static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count) { diff --git a/src/lexspaces.c b/src/lexspaces.c index 6e6a7a3a541..5de227bb1a9 100644 --- a/src/lexspaces.c +++ b/src/lexspaces.c @@ -20,8 +20,6 @@ along with GNU Emacs. If not, see . */ #include #include "lisp.h" -EMACS_INT curr_lexspace; - /* Store lexnumber in closure + set lexspace calling subrs. */ static void @@ -69,12 +67,12 @@ DEFUN ("lexspace-make-from", Flexspace_make_from, Slexspace_make_from, 2, 2, 0, EMACS_INT lexspace_num = XFIXNUM (Fhash_table_count (Vlexspaces)); if (lexspace_num == MAX_LEXSPACES) error ("Max number of lexspaces reached"); - Lisp_Object src_lex_n = Fgethash (src, Vlexspaces, Qnil); - if (NILP (src_lex_n)) + Lisp_Object src_idx = Fgethash (src, Vlexspaces, Qnil); + if (NILP (src_idx)) error ("lexspace %s does not exists", SSDATA (SYMBOL_NAME (src))); Fputhash (name, make_fixnum (lexspace_num), Vlexspaces); - lexspace_copy (lexspace_num, XFIXNUM (src_lex_n)); + lexspace_copy (lexspace_num, XFIXNUM (src_idx)); return name; } @@ -84,10 +82,10 @@ DEFUN ("in-lexspace", Fin_lexspace, Sin_lexspace, 1, 1, 0, (Lisp_Object name) { CHECK_SYMBOL (name); - Lisp_Object src_lex_n = Fgethash (name, Vlexspaces, Qnil); - if (NILP (src_lex_n)) + Lisp_Object src_idx = Fgethash (name, Vlexspaces, Qnil); + if (NILP (src_idx)) error ("lexspace %s does not exists", SSDATA (SYMBOL_NAME (name))); - curr_lexspace = XFIXNUM (src_lex_n); + Vcurrent_lexspace_idx = src_idx; return name; } @@ -97,6 +95,7 @@ syms_of_lexspaces (void) { DEFSYM (Qbinding, "binding"); DEFSYM (Qel, "el"); + DEFSYM (Qcurrent_lexspace_idx, "current-lexspace-idx"); /* Internal use! */ DEFVAR_LISP ("lexspaces", Vlexspaces, @@ -104,6 +103,8 @@ syms_of_lexspaces (void) Vlexspaces = CALLN (Fmake_hash_table, QCtest, Qeq); Fputhash (Qel, make_fixnum (0), Vlexspaces); + DEFVAR_LISP ("current-lexspace-idx", Vcurrent_lexspace_idx, + doc: /* Internal use. */); defsubr (&Sin_lexspace); defsubr (&Slexspace_make_from); } diff --git a/src/lisp.h b/src/lisp.h index 7cbbe44b5a0..057a7fe8a42 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2169,7 +2169,7 @@ typedef jmp_buf sys_jmp_buf; #define MAX_LEXSPACES 256 -extern EMACS_INT curr_lexspace; +#define CURRENT_LEXSPACE XFIXNUM (Vcurrent_lexspace_idx) INLINE Lisp_Object make_binding (Lisp_Object); @@ -2214,7 +2214,7 @@ SYMBOL_VAL (struct Lisp_Symbol *sym) if (EQ (sym->u.s.val.value, Qunbound)) return Qunbound; eassert (BINDINGP (sym->u.s.val.value)); - EMACS_INT lexspace = curr_lexspace; + EMACS_INT lexspace = CURRENT_LEXSPACE; struct Lisp_Binding *binding = XBINDING (sym->u.s.val.value); /* Follow redirections. */ while (binding->r[lexspace]) @@ -2227,7 +2227,7 @@ symbol_function_1 (struct Lisp_Symbol *sym) { if (NILP (sym->u.s._function)) return Qnil; - EMACS_INT lexspace = curr_lexspace; + EMACS_INT lexspace = CURRENT_LEXSPACE; struct Lisp_Binding *binding = XBINDING (sym->u.s._function); /* Follow redirections. */ while (binding->r[lexspace]) @@ -2242,11 +2242,11 @@ SYMBOL_FUNCTION (struct Lisp_Symbol *sym) if (CONSP (tmp) && CONSP (XCDR (tmp)) - && EQ (XCAR (XCDR (tmp)), Qclosure)) + && EQ (XCAR (XCDR (tmp)), Qclosure) + && FIXNUMP (XCAR (tmp))) { /* Remove the lexspace number in case (n closure () ...) is found. */ - eassert (FIXNUMP (XCAR (tmp))); return XCDR (tmp); } return tmp; @@ -2259,11 +2259,11 @@ SYMBOL_FUNC_LEXSPACE (struct Lisp_Symbol *sym) if (CONSP (tmp) && CONSP (XCDR (tmp)) - && EQ (XCAR (XCDR (tmp)), Qclosure)) + && EQ (XCAR (XCDR (tmp)), Qclosure) + && FIXNUMP (XCAR (tmp))) { /* Remove the lexspace number in case (n closure () ...) is found. */ - eassert (FIXNUMP (XCAR (tmp))); return XCAR (tmp); } return Qnil; @@ -2296,8 +2296,8 @@ SET_SYMBOL_VAL (struct Lisp_Symbol *sym, Lisp_Object v) if (EQ (sym->u.s.val.value, Qunbound)) sym->u.s.val.value = make_binding (Qunbound); struct Lisp_Binding *binding = XBINDING (sym->u.s.val.value); - binding->r[curr_lexspace] = false; - binding->b[curr_lexspace] = v; + binding->r[CURRENT_LEXSPACE] = false; + binding->b[CURRENT_LEXSPACE] = v; } INLINE void @@ -3482,8 +3482,8 @@ set_symbol_function (Lisp_Object sym, Lisp_Object function) s->u.s._function = make_binding (Qnil); /* Functions must execute in the original lexspace so lets store it. */ if (CONSP (function) && EQ (XCAR (function), Qclosure)) - function = Fcons (make_fixnum (curr_lexspace), function); - XBINDING (s->u.s._function)->b[curr_lexspace] = function; + function = Fcons (Vcurrent_lexspace_idx, function); + XBINDING (s->u.s._function)->b[CURRENT_LEXSPACE] = function; } INLINE void -- cgit v1.2.1