core: Make 'primitive-load' a builtin.

In addition to simplifying the interpreter, this change ensures that
'primitive-load' evaluates the loaded file in the top level
environment.

* include/mes/symbols.h (cell_symbol_primitive_load): Remove
variable.
(cell_vm_begin_primitive_load): Remove variable.
(cell_vm_begin_expand_primitive_load): Remove variable.
(SYMBOL_MAX, CELL_SYMBOL_RECORD_TYPE): Adjust accordingly.
* src/symbol.c (init_symbols): Do not initialize removed variables.
* src/eval-apply.c (eval_apply): Remove primitive load code.
(primitive_load): New function.
* include/mes/builtins.h (primitive_load): Declare it.
* src/builtins.c (mes_builtins): Initialize it.
* mes/module/mes/boot-03.scm: Remove duplicate call to
'primitive-load'.
* mes/module/mes/boot-0.scm: Remove extra call to 'primitive-load';
adjust how the "--main" option is handled.
* tests/base/test.test: Add a test.
* tests/data/load.scm: Set the 'toplevel?' variable to support the
new test.

include/mes/builtins.h

@@ -55,6 +55,7 @@ struct scm *set_car_x (struct scm *x, struct scm *e);
 struct scm *set_cdr_x (struct scm *x, struct scm *e);
 struct scm *add_formals (struct scm *formals, struct scm *x);
 struct scm *eval_apply ();
+struct scm *primitive_load (struct scm *filename);
 /* src/gc.c */
 struct scm *gc_stats ();
 struct scm *cons (struct scm *x, struct scm *y);

include/mes/symbols.h

@@ -38,8 +38,6 @@ extern struct scm *cell_vm_begin_eval;
 extern struct scm *cell_vm_begin_expand;
 extern struct scm *cell_vm_begin_expand_eval;
 extern struct scm *cell_vm_begin_expand_macro;
-extern struct scm *cell_vm_begin_expand_primitive_load;
-extern struct scm *cell_vm_begin_primitive_load;
 extern struct scm *cell_vm_begin_read_input_file;
 extern struct scm *cell_vm_call_with_current_continuation2;
 extern struct scm *cell_vm_call_with_values2;
@@ -87,7 +85,6 @@ extern struct scm *cell_symbol_sc_expander_alist;
 extern struct scm *cell_symbol_call_with_values;
 extern struct scm *cell_symbol_call_with_current_continuation;
 extern struct scm *cell_symbol_current_environment;
-extern struct scm *cell_symbol_primitive_load;
 extern struct scm *cell_symbol_car;
 extern struct scm *cell_symbol_cdr;
 extern struct scm *cell_symbol_not_a_number;
@@ -136,14 +133,14 @@ extern struct scm *cell_type_broken_heart;
 extern struct scm *cell_symbol_program;
 extern struct scm *cell_symbol_test;
 
-// CONSTANT SYMBOL_MAX 114
-#define SYMBOL_MAX 114
+// CONSTANT SYMBOL_MAX 111
+#define SYMBOL_MAX 111
 
 // CONSTANT CELL_UNSPECIFIED 7
 #define CELL_UNSPECIFIED 7
 
-// CONSTANT CELL_SYMBOL_RECORD_TYPE 80
-#define CELL_SYMBOL_RECORD_TYPE 80
+// CONSTANT CELL_SYMBOL_RECORD_TYPE 77
+#define CELL_SYMBOL_RECORD_TYPE 77
 
 
 #endif /* __MES_SYMBOLS_H */

mes/module/mes/boot-0.scm

@@ -2,6 +2,7 @@
 
 ;;; GNU Mes --- Maxwell Equations of Software
 ;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2022 Timothy Sample <samplet@ngyro.com>
 ;;;
 ;;; This file is part of GNU Mes.
 ;;;
@@ -205,7 +206,7 @@
 (mes-use-module (mes getopt-long))
 
 (define %main #f)
-(primitive-load 0)
+
 (let ((tty? (isatty? 0)))
   (define (parse-opts args)
     (let* ((option-spec
@@ -274,7 +275,9 @@ General help using GNU software: <http://gnu.org/gethelp/>
              (set-current-input-port prev))
         (primitive-eval expr)
         (exit 0)))
-    (when main (set! %main main))
+    (when main
+      (let ((proc-name (string->symbol main)))
+        (set! %main (lambda () (apply proc-name (command-line) '())))))
     (cond ((pair? files)
            (let* ((file (car files))
                   (port (if (equal? file "-") 0
@@ -288,4 +291,4 @@ General help using GNU software: <http://gnu.org/gethelp/>
            (repl))
           (else #t))))
 (primitive-load 0)
-(primitive-load (open-input-string %main))
+(if %main (%main))

mes/module/mes/boot-03.scm

@@ -172,4 +172,3 @@
 (define-macro (use-modules . rest) #t)
 ;; end boot-03.scm
 (primitive-load 0)
-(primitive-load 0)

src/builtins.c

@@ -165,6 +165,7 @@ mes_builtins (struct scm *a)            /*:((internal)) */
   a = init_builtin (builtin_type, "set-cdr!", 2, &set_cdr_x, a);
   a = init_builtin (builtin_type, "add-formals", 2, &add_formals, a);
   a = init_builtin (builtin_type, "eval-apply", 0, &eval_apply, a);
+  a = init_builtin (builtin_type, "primitive-load", 1, &primitive_load, a);
   /* src/gc.c */
   a = init_builtin (builtin_type, "gc-stats", 0, &gc_stats, a);
   a = init_builtin (builtin_type, "cons", 2, &cons, a);

src/eval-apply.c

@@ -310,7 +310,6 @@ expand_variable_ (struct scm *x, struct scm *formals, int top_p)        /*:((int
             return cell_unspecified;
           else if (a->type == TSYMBOL
                    && a != cell_symbol_current_environment
-                   && a != cell_symbol_primitive_load
                    && formal_p (x->car, formals) == 0)
             {
               v = lookup_binding (a);
@@ -436,9 +435,6 @@ eval_apply:
     goto eval_pmatch_cdr;
   else if (R3 == cell_vm_macro_expand_define_macro)
     goto macro_expand_define_macro;
-  else if (R3 == cell_vm_begin_primitive_load)
-    goto begin_primitive_load;
-
   else if (R3 == cell_vm_evlis)
     goto evlis;
   else if (R3 == cell_vm_apply)
@@ -453,8 +449,6 @@ eval_apply:
     goto begin;
   else if (R3 == cell_vm_begin_expand)
     goto begin_expand;
-  else if (R3 == cell_vm_begin_expand_primitive_load)
-    goto begin_expand_primitive_load;
   else if (R3 == cell_vm_if)
     goto vm_if;
   else if (R3 == cell_vm_call_with_values2)
@@ -863,19 +857,6 @@ begin:
   while (R1 != cell_nil)
     {
       gc_check ();
-      if (R1->type == TPAIR)
-        {
-          if (R1->car->car == cell_symbol_primitive_load)
-            {
-              program = cons (R1->car, cell_nil);
-              push_cc (program, R1, R0, cell_vm_begin_primitive_load);
-              goto begin_expand;
-            begin_primitive_load:
-              R2->car = R1;
-              R1 = R2;
-            }
-        }
-
       if (R1->type == TPAIR)
         {
           a = R1->car;
@@ -913,41 +894,6 @@ begin_expand:
           if (a->type == TPAIR)
             if (R1->car->car == cell_symbol_begin)
               R1 = append2 (R1->car->cdr, R1->cdr);
-          if (R1->car->car == cell_symbol_primitive_load)
-            {
-              push_cc (R1->car->cdr->car, R1, R0, cell_vm_begin_expand_primitive_load);
-              goto eval;
-            begin_expand_primitive_load:
-              if ((R1->type == TNUMBER) && R1->value == 0)
-                0;
-              else if (R1->type == TSTRING)
-                input = set_current_input_port (open_input_file (R1));
-              else if (R1->type == TPORT)
-                input = set_current_input_port (R1);
-              else
-                {
-                  eputs ("begin_expand failed, R1=");
-                  display_error_ (R1);
-                  assert_msg (0, "begin-expand-boom 0");
-                }
-
-              push_cc (input, R2, R0, cell_vm_return);
-              x = read_input_file_env (R0);
-              if (g_debug > 5)
-                {
-                  eputs ("initial module obarray\n");
-                  hash_table_printer (M0);
-                }
-              gc_pop_frame ();
-              input = R1;
-              R1 = x;
-              set_current_input_port (input);
-              R1 = cons (cell_symbol_begin, R1);
-              R2->car = R1;
-              R1 = R2;
-              goto begin_expand_while;
-              continue; /* FIXME: M2-PLanet */
-            }
         }
 
       push_cc (R1->car, R1, R0, cell_vm_begin_expand_macro);
@@ -1031,3 +977,39 @@ apply (struct scm *f, struct scm *x, struct scm *a)     /*:((internal)) */
   R3 = cell_vm_apply;
   return eval_apply ();
 }
+
+struct scm *
+primitive_load (struct scm *filename)     /*:((arity . 1))*/
+{
+  struct scm *input;
+
+  if ((filename->type == TNUMBER) && filename->value == 0)
+    input = current_input_port ();
+  else if (filename->type == TSTRING)
+    input = set_current_input_port (open_input_file (filename));
+  else if (filename->type == TPORT)
+    input = set_current_input_port (filename);
+  else
+    {
+      eputs ("primitive_load failed, filename=");
+      display_error_ (filename);
+      assert_msg (0, "primitive-load-boom 0");
+    }
+
+  struct scm *forms = read_input_file_env (cell_nil);
+  forms = cons (cell_symbol_begin, forms);
+
+  struct scm *env = cell_nil;
+  env = cons (cons (cell_symbol_program, forms), env);
+
+  gc_push_frame ();
+  /* Store 'input' in R2 so it does not get GCed during evaluation. */
+  push_cc (forms, input, env, cell_unspecified);
+  R3 = cell_vm_begin_expand;
+  struct scm *result = eval_apply ();
+  input = R2;
+  gc_pop_frame ();
+
+  set_current_input_port (input);
+  return result;
+}

src/symbol.c

@@ -72,8 +72,6 @@ init_symbols_ ()                  /*:((internal)) */
   cell_vm_begin_expand = init_symbol (g_symbol, TSPECIAL, "core:eval");
   cell_vm_begin_expand_eval = init_symbol (g_symbol, TSPECIAL, "*vm:begin-expand-eval*");
   cell_vm_begin_expand_macro = init_symbol (g_symbol, TSPECIAL, "*vm:begin-expand-macro*");
-  cell_vm_begin_expand_primitive_load = init_symbol (g_symbol, TSPECIAL, "*vm:core:begin-expand-primitive-load*");
-  cell_vm_begin_primitive_load = init_symbol (g_symbol, TSPECIAL, "*vm:core:begin-primitive-load*");
   cell_vm_begin_read_input_file = init_symbol (g_symbol, TSPECIAL, "*vm-begin-read-input-file*");
   cell_vm_call_with_current_continuation2 = init_symbol (g_symbol, TSPECIAL, "*vm-call-with-current-continuation2*");
   cell_vm_call_with_values2 = init_symbol (g_symbol, TSPECIAL, "*vm-call-with-values2*");
@@ -121,7 +119,6 @@ init_symbols_ ()                  /*:((internal)) */
   cell_symbol_call_with_values = init_symbol (g_symbol, TSYMBOL, "call-with-values");
   cell_symbol_call_with_current_continuation = init_symbol (g_symbol, TSYMBOL, "call-with-current-continuation");
   cell_symbol_current_environment = init_symbol (g_symbol, TSYMBOL, "current-environment");
-  cell_symbol_primitive_load = init_symbol (g_symbol, TSYMBOL, "primitive-load");
   cell_symbol_car = init_symbol (g_symbol, TSYMBOL, "car");
   cell_symbol_cdr = init_symbol (g_symbol, TSYMBOL, "cdr");
   cell_symbol_not_a_number = init_symbol (g_symbol, TSYMBOL, "not-a-number");

tests/base.test

@@ -112,8 +112,16 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
   (define local-answer 41))
 (pass-if-equal "begin 2" 41 (begin local-answer))
 
+(define toplevel? #f)
+
 (pass-if-equal "primitive-load" 42 (primitive-load "tests/data/load.scm") the-answer)
 
+(pass-if-equal "primitive-load-toplevel"
+    #t
+  ((lambda ()
+     (primitive-load "tests/data/load.scm")))
+  toplevel?)
+
 (cond-expand
  (mes
   (pass-if-equal "include" 42 (include "tests/data/load.scm") the-answer))

tests/data/load.scm

@@ -2,6 +2,7 @@
 
 ;;; GNU Mes --- Maxwell Equations of Software
 ;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2022 Timothy Sample <samplet@ngyro.com>
 ;;;
 ;;; This file is part of GNU Mes.
 ;;;
@@ -19,3 +20,10 @@
 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
 
 (define the-answer 42)
+
+(set! toplevel?
+      ;; If the module system has booted or we are running on Guile,
+      ;; assume everything is okay.
+      (if (current-module)
+          #t
+          (if (eq? '*closure* (car (car (current-environment)))) #f #t)))