core: Make symbol lookup extensible.

* src/module.c (set_current_module): New function.
(module_variable): Remove function.
(module_define_x): Remove function.
(current_module_variable): New function.
* src/eval-apply.c (lookup_binding): Replace 'module_variable' with
'current_module_variable'; add the 'define_p' argument.
(set_x): Adjust for 'define_p'.
(lookup_value): Likewise.
(expand_variable_): Likewise.
(eval_apply): When evaluating defines, replace 'module_define_x' with
'lookup_binding' with 'define_p' set.
* src/gc.c (gc_init)[!M2_PLANET]: Double ARENA_SIZE.
* include/mes/constants.h (MODULE_EVAL_CLOSURE): New constant.
* include/mes/mes.h (current_module_variable): New declaration.
(current_module_define_x): New declaration.
* include/mes/builtins.h (set_current_module): New declaration.
(lookup_binding): Declare the 'define_p' argument.
(module_variable): Remove declaration.
(module_define_x): Remove declaration.
* src/builtins.c (mes_builtins): Register 'set-current-module';
remove 'module-variable' and 'module-define!'.
* mes/module/boot-0.scm (defined?): Do not use 'module-variable'.
* mes/module/boot-00.scm (defined?): Likewise.
* mes/module/boot-01.scm (defined?): Likewise.
* mes/module/boot-02.scm (defined?): Likewise.
* mes/module/boot-03.scm (defined?): Likewise.
* scaffold/boot/60-let-syntax-expanded.scm (defined?): Likewise.
* mes/module/mes/fluids.mes (make-fluid): Do not use
'module-define!', and wrap fluids in a variable record.
* tests/macro.test (make-fluid): Likewise.

Co-authored-by: Jan (janneke) Nieuwenhuizen <janneke@gnu.org>

include/mes/builtins.h

@@ -101,10 +101,9 @@ struct scm *lognot (struct scm *x);
 struct scm *logxor (struct scm *x);
 struct scm *ash (struct scm *n, struct scm *count);
 /* src/module.c */
-struct scm *module_variable (struct scm *module, struct scm *name);
-struct scm *module_define_x (struct scm *module, struct scm *name, struct scm *value);
 struct scm *initial_module ();
 struct scm *current_module ();
+struct scm *set_current_module (struct scm *module);
 /* src/posix.c */
 struct scm *abort_ ();
 struct scm *exit_ (struct scm *x);

include/mes/constants.h

@@ -73,6 +73,9 @@
 // CONSTANT FRAME_PROCEDURE 4
 #define FRAME_PROCEDURE 4
 
+// CONSTANT MODULE_EVAL_CLOSURE 6
+#define MODULE_EVAL_CLOSURE 6
+
 // CONSTANT STDIN 0
 // CONSTANT STDOUT 1
 // CONSTANT STDERR 2

include/mes/mes.h

@@ -131,10 +131,11 @@ struct scm *builtin_name (struct scm *builtin);
 struct scm *cstring_to_list (char const *s);
 struct scm *cstring_to_symbol (char const *s);
 struct scm *cell_ref (struct scm *cell, long index);
+struct scm *current_module_variable (struct scm *name, struct scm *define_p);
 struct scm *fdisplay_ (struct scm *, int, int);
 struct scm *init_symbols ();
 struct scm *init_time (struct scm *a);
-struct scm *lookup_binding (struct scm *name);
+struct scm *lookup_binding (struct scm *name, struct scm *define_p);
 struct scm *lookup_value (struct scm *name);
 struct scm *make_builtin_type ();
 struct scm *make_bytes (char const *s, size_t length);

mes/module/mes/boot-0.scm

@@ -31,7 +31,7 @@
 (define mes %version)
 
 (define (defined? x)
-  (module-variable (current-environment) x))
+  (core:hashq-ref (initial-module) x #f))
 
 (define (cond-expand-expander clauses)
   (if (defined? (car (car clauses)))

mes/module/mes/boot-00.scm

@@ -20,7 +20,7 @@
 (define mes %version)
 
 (define (defined? x)
-  (module-variable (current-environment) x))
+  (core:hashq-ref (initial-module) x #f))
 
 (define (cond-expand-expander clauses)
   (if (defined? (car (car clauses)))

mes/module/mes/boot-01.scm

@@ -20,7 +20,7 @@
 (define mes %version)
 
 (define (defined? x)
-  (module-variable (current-environment) x))
+  (core:hashq-ref (initial-module) x #f))
 
 (define (cond-expand-expander clauses)
   (if (defined? (car (car clauses)))

mes/module/mes/boot-02.scm

@@ -30,7 +30,7 @@
 (define mes %version)
 
 (define (defined? x)
-  (module-variable (current-environment) x))
+  (core:hashq-ref (initial-module) x #f))
 
 (define (cond-expand-expander clauses)
   (if (defined? (car (car clauses)))

mes/module/mes/boot-03.scm

@@ -30,7 +30,7 @@
 (define mes %version)
 
 (define (defined? x)
-  (module-variable (current-environment) x))
+  (core:hashq-ref (initial-module) x #f))
 
 (define (cond-expand-expander clauses)
   (if (defined? (car (car clauses)))

mes/module/mes/fluids.mes

@@ -27,14 +27,15 @@
 (define-macro (make-fluid . default)
   ((lambda (fluid)
      `(begin
-        (module-define!
+        (hashq-set!
          (initial-module)
-        ',fluid
-        ((lambda (v)
-           (lambda ( . rest)
-             (if (null? rest) v
-                 (set! v (car rest)))))
-         ,(and (pair? default) (car default))))
+         ',fluid
+         (make-variable
+          ((lambda (v)
+             (lambda ( . rest)
+               (if (null? rest) v
+                   (set! v (car rest)))))
+           ,(and (pair? default) (car default)))))
         ',fluid))
    (symbol-append 'fluid: (gensym))))
 

scaffold/boot/60-let-syntax-expanded.scm

@@ -20,7 +20,7 @@
 (define mes %version)
 
 (define (defined? x)
-  (module-variable (current-environment) x))
+  (core:hashq-ref (initial-module) x #f))
 
 (define (cond-expand-expander clauses)
   (if (defined? (car (car clauses)))

src/builtins.c

@@ -211,10 +211,9 @@ mes_builtins (struct scm *a)            /*:((internal)) */
   a = init_builtin (builtin_type, "logxor", -1, &logxor, a);
   a = init_builtin (builtin_type, "ash", 2, &ash, a);
   /* src/module.c */
-  a = init_builtin (builtin_type, "module-variable", 2, &module_variable, a);
-  a = init_builtin (builtin_type, "module-define!", 3, &module_define_x, a);
   a = init_builtin (builtin_type, "initial-module", 0, &initial_module, a);
   a = init_builtin (builtin_type, "current-module", 0, &current_module, a);
+  a = init_builtin (builtin_type, "set-current-module", 1, &set_current_module, a);
   /* src/posix.c */
   a = init_builtin (builtin_type, "abort", 0, &abort_, a);
   a = init_builtin (builtin_type, "exit", 1, &exit_, a);

src/eval-apply.c

@@ -129,7 +129,7 @@ set_x (struct scm *x, struct scm *e)
   if (x->type == TBINDING)
     binding = x;
   else
-    binding = lookup_binding (x);
+    binding = lookup_binding (x, cell_f);
 
   if (binding == cell_f)
     return error (cell_symbol_unbound_variable, x);
@@ -205,15 +205,15 @@ push_cc (struct scm *p1, struct scm *p2, struct scm *a, struct scm *c)  /*:((int
 }
 
 struct scm *
-lookup_binding (struct scm *name)
+lookup_binding (struct scm *name, struct scm *define_p)
 {
   struct scm *handle = assq (name, R0);
   if (handle != cell_f)
     return make_binding_ (handle, 1);
 
-  handle = module_variable (M0, name);
-  if (handle != cell_f)
-    return make_binding_ (handle, 0);
+  struct scm *variable = current_module_variable (name, define_p);
+  if (variable != cell_f)
+    return make_binding_ (cons (name, variable), 0);
 
   return cell_f;
 }
@@ -221,7 +221,7 @@ lookup_binding (struct scm *name)
 struct scm *
 lookup_value (struct scm *name)
 {
-  struct scm *binding = lookup_binding (name);
+  struct scm *binding = lookup_binding (name, cell_f);
   if (binding != cell_f)
     {
       if (binding->lexical_p != 0)
@@ -316,7 +316,7 @@ expand_variable_ (int top_p)        /*:((internal)) */
                    && a != cell_symbol_current_environment
                    && formal_p (a, R2) == 0)
             {
-              v = lookup_binding (a);
+              v = lookup_binding (a, cell_f);
               if (v != cell_f)
                 R1->car = v;
             }
@@ -677,11 +677,9 @@ eval:
                       }
                     else
                       {
-                        R2 = name;
-                        entry = lookup_binding (name);
-                        name = R2;
-                        if (entry == cell_f)
-                          module_define_x (M0, name, cell_f);
+                        /* Ensure this name is bound in the current
+                           module. */
+                        lookup_binding (name, cell_t);
                       }
                   }
                 R2 = R1;

src/gc.c

@@ -57,7 +57,7 @@ gc_init ()
 #if SYSTEM_LIBC
   ARENA_SIZE = 100000000;       /* 2.3GiB */
 #elif ! __M2_PLANET__
-  ARENA_SIZE = 300000;          /* 32b: 3MiB, 64b: 6 MiB */
+  ARENA_SIZE = 600000;          /* 32b: 6MiB, 64b: 12 MiB */
 #else
   ARENA_SIZE = 20000000;
 #endif

src/module.c

@@ -48,16 +48,42 @@ current_module ()
 }
 
 struct scm *
-module_variable (struct scm *module, struct scm *name)
+set_current_module (struct scm *module)
 {
-  module = M0;
-  return hashq_get_handle (module, name);
+  struct scm *previous = M1;
+  M1 = module;
+  return previous;
 }
 
 struct scm *
-module_define_x (struct scm *module, struct scm *name, struct scm *value)
+current_module_variable (struct scm *name, struct scm *define_p)
 {
-  module = M0;
-  struct scm *var = make_variable (value);
-  return hashq_set_x (module, name, var);
+  struct scm *module = current_module ();
+
+  /* When '(current-module)' is false, that means the module system is
+     not yet booted.  In that case, we lookup variables in the initial
+     module hash table. */
+  if (module == cell_f)
+    {
+      module = initial_module ();
+      struct scm *variable = hashq_ref_ (module, name, cell_f);
+      if (variable == cell_f && define_p != cell_f)
+        return hashq_set_x (module, name, make_variable (cell_undefined));
+      else
+        return variable;
+    }
+
+  /* The module system is booted.  We can use the current module's
+     'eval-closure' procedure.  We take it on faith that whatever is in
+     'M1' is a module. */
+  struct scm *eval_closure = struct_ref_ (module, MODULE_EVAL_CLOSURE);
+  struct scm *args = cell_nil;
+  args = cons (define_p, args);
+  args = cons (name, args);
+  /* XXX: Calling 'apply' does not restore the registers properly.  We
+     work around it here, but maybe it should be fixed in 'apply'. */
+  gc_push_frame ();
+  struct scm *result = apply (eval_closure, args, cell_nil);
+  gc_pop_frame ();
+  return result;
 }

tests/macro.test

@@ -68,15 +68,15 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
      (list
       'begin
       (list
-       'module-define!
+       'hashq-set!
        (list 'initial-module)
        (list 'quote fluid)
-       (list
-        (lambda (v)
-          (lambda ( . rest)
-            (if (null? rest) v
-                (set! v (car rest)))))
-        (and (pair? default) (car default))))
+       (list 'make-variable
+             (list (lambda (v)
+                     (lambda ( . rest)
+                       (if (null? rest) v
+                           (set! v (car rest)))))
+                   (and (pair? default) (car default)))))
       (list 'quote fluid)))
    (symbol-append 'fluid: (gensym))))