[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/lexspaces c578c72 11/17: Add function lexspace contex mechanism
From: |
Andrea Corallo |
Subject: |
scratch/lexspaces c578c72 11/17: Add function lexspace contex mechanism |
Date: |
Fri, 8 May 2020 16:43:09 -0400 (EDT) |
branch: scratch/lexspaces
commit c578c72aae601462a5ece8cc15aa6d13bc80e196
Author: Andrea Corallo <address@hidden>
Commit: Andrea Corallo <address@hidden>
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 5199238..1ab96a7 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 a826a60..38798ee 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 7e2fbca..2bf8dcb 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);
}
@@ -2905,6 +2922,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)
{
Lisp_Object *arg_vector;
diff --git a/src/lexspaces.c b/src/lexspaces.c
index 6e6a7a3..5de227b 100644
--- a/src/lexspaces.c
+++ b/src/lexspaces.c
@@ -20,8 +20,6 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include <config.h>
#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 7cbbe44..057a7fe 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
- scratch/lexspaces 7fecbf5 08/17: Add lexspace redirection, (continued)
- scratch/lexspaces 7fecbf5 08/17: Add lexspace redirection, Andrea Corallo, 2020/05/08
- scratch/lexspaces 09821e3 03/17: Store symbol value into the binding, Andrea Corallo, 2020/05/08
- scratch/lexspaces 04ac507 14/17: Remove unnecessary assertion, Andrea Corallo, 2020/05/08
- scratch/lexspaces 00108a5 15/17: Fix sweep_symbols, Andrea Corallo, 2020/05/08
- scratch/lexspaces 295ac3d 07/17: Make in-lexspace do something, Andrea Corallo, 2020/05/08
- scratch/lexspaces 610552d 10/17: Add SYMBOL_FUNC_LEXSPACE, Andrea Corallo, 2020/05/08
- scratch/lexspaces 9091913 13/17: Rename lexspace-make-from -> lexspace-make, Andrea Corallo, 2020/05/08
- scratch/lexspaces e2f183c 17/17: Shallow setters by default are not a good idea, Andrea Corallo, 2020/05/08
- scratch/lexspaces 73363e9 09/17: Store lexspace in closures, Andrea Corallo, 2020/05/08
- scratch/lexspaces b46c504 12/17: Add lexspace-import-symbol, Andrea Corallo, 2020/05/08
- scratch/lexspaces c578c72 11/17: Add function lexspace contex mechanism,
Andrea Corallo <=
- scratch/lexspaces 0b0098a 16/17: Rename in-lexspace -> lexspace-in, Andrea Corallo, 2020/05/08