scratch/lexspaces c578c72 11/17: Add function lexspace contex mechanism

[Andrea Corallo]

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