core: Split-out stack.c

* src/lib.c (exit_, frame_printer, make_frame_type, make_frame,
make_stack_type, make_stack, stack_length, stack_ref_): Move to ..
* src/posix.c (exit_): Here and to ..
* src/core.c: New file.
* build-aux/configure-lib.sh (mes_SOURCES): Add it.
* simple.make (LIBMES_SOURCES): Likewise.
* build-aux/snarf.sh: Likewise.
* include/mes/builtins.h: Update.
* src/builtins.c (mes_builtins): Update.

build-aux/configure-lib.sh

@@ -442,6 +442,7 @@ src/mes.c
 src/module.c
 src/posix.c
 src/reader.c
+src/stack.c
 src/string.c
 src/struct.c
 src/symbol.c

build-aux/pointer.sh

@@ -58,6 +58,7 @@ sed -ri                                                         \
     src/module.c                                                \
     src/posix.c                                                 \
     src/reader.c                                                \
+    src/stack.c                                                 \
     src/string.c                                                \
     src/struct.c                                                \
     src/symbol.c                                                \

build-aux/snarf.sh

@@ -36,6 +36,7 @@ trace "SNARF$snarf  mes.c"        ${srcdest}build-aux/mes-snarf.scm src/mes.c
 trace "SNARF$snarf  module.c"     ${srcdest}build-aux/mes-snarf.scm src/module.c
 trace "SNARF$snarf  posix.c"      ${srcdest}build-aux/mes-snarf.scm src/posix.c
 trace "SNARF$snarf  reader.c"     ${srcdest}build-aux/mes-snarf.scm src/reader.c
+trace "SNARF$snarf  stack.c"      ${srcdest}build-aux/mes-snarf.scm src/stack.c
 trace "SNARF$snarf  strings.c"    ${srcdest}build-aux/mes-snarf.scm src/string.c
 trace "SNARF$snarf  struct.c"     ${srcdest}build-aux/mes-snarf.scm src/struct.c
 trace "SNARF$snarf  symbol.c"     ${srcdest}build-aux/mes-snarf.scm src/symbol.c

include/mes/builtins.h

@@ -74,11 +74,6 @@ SCM make_hash_table (SCM x);
 SCM type_ (SCM x);
 SCM car_ (SCM x);
 SCM cdr_ (SCM x);
-SCM exit_ (SCM x);
-SCM frame_printer (SCM frame);
-SCM make_stack (SCM stack);
-SCM stack_length (SCM stack);
-SCM stack_ref (SCM stack, SCM index);
 SCM xassq (SCM x, SCM a);
 SCM memq (SCM x, SCM a);
 SCM equal2_p (SCM a, SCM b);
@@ -107,6 +102,7 @@ SCM module_variable (SCM module, SCM name);
 SCM module_ref (SCM module, SCM name);
 SCM module_define_x (SCM module, SCM name, SCM value);
 /* src/posix.c */
+SCM exit_ (SCM x);
 SCM peek_byte ();
 SCM read_byte ();
 SCM unread_byte (SCM i);
@@ -149,6 +145,11 @@ SCM reader_read_binary ();
 SCM reader_read_octal ();
 SCM reader_read_hex ();
 SCM reader_read_string ();
+/* src/stack.c */
+SCM frame_printer (SCM frame);
+SCM make_stack (SCM stack);
+SCM stack_length (SCM stack);
+SCM stack_ref (SCM stack, SCM index);
 /* src/string.c */
 SCM string_equal_p (SCM a, SCM b);
 SCM symbol_to_string (SCM symbol);

simple.make

@@ -60,6 +60,7 @@ MES_SOURCES =					\
  src/posix.c					\
  src/reader.c					\
  src/string.c					\
+ src/stack.c					\
  src/struct.c					\
  src/symbol.c					\
  src/vector.c

src/builtins.c

@@ -167,11 +167,6 @@ mes_builtins (SCM a)            /*:((internal)) */
   a = init_builtin (builtin_type, "core:type", 1, &type_, a);
   a = init_builtin (builtin_type, "core:car", 1, &car_, a);
   a = init_builtin (builtin_type, "core:cdr", 1, &cdr_, a);
-  a = init_builtin (builtin_type, "exit", 1, &exit_, a);
-  a = init_builtin (builtin_type, "frame-printer", 1, &frame_printer, a);
-  a = init_builtin (builtin_type, "make-stack", -1, &make_stack, a);
-  a = init_builtin (builtin_type, "stack-length", 1, &stack_length, a);
-  a = init_builtin (builtin_type, "stack-ref", 2, &stack_ref, a);
   a = init_builtin (builtin_type, "xassq", 2, &xassq, a);
   a = init_builtin (builtin_type, "memq", 2, &memq, a);
   a = init_builtin (builtin_type, "equal2?", 2, &equal2_p, a);
@@ -200,6 +195,7 @@ mes_builtins (SCM a)            /*:((internal)) */
   a = init_builtin (builtin_type, "module-ref", 2, &module_ref, a);
   a = init_builtin (builtin_type, "module-define!", 3, &module_define_x, a);
   /* src/posix.c */
+  a = init_builtin (builtin_type, "exit", 1, &exit_, a);
   a = init_builtin (builtin_type, "peek-byte", 0, &peek_byte, a);
   a = init_builtin (builtin_type, "read-byte", 0, &read_byte, a);
   a = init_builtin (builtin_type, "unread-byte", 1, &unread_byte, a);
@@ -242,6 +238,11 @@ mes_builtins (SCM a)            /*:((internal)) */
   a = init_builtin (builtin_type, "reader-read-octal", 0, &reader_read_octal, a);
   a = init_builtin (builtin_type, "reader-read-hex", 0, &reader_read_hex, a);
   a = init_builtin (builtin_type, "reader-read-string", 0, &reader_read_string, a);
+  /* src/stack.c */
+  a = init_builtin (builtin_type, "frame-printer", 1, &frame_printer, a);
+  a = init_builtin (builtin_type, "make-stack", -1, &make_stack, a);
+  a = init_builtin (builtin_type, "stack-length", 1, &stack_length, a);
+  a = init_builtin (builtin_type, "stack-ref", 2, &stack_ref, a);
   /* src/string.c */
   a = init_builtin (builtin_type, "string=?", 2, &string_equal_p, a);
   a = init_builtin (builtin_type, "symbol->string", 1, &symbol_to_string, a);

src/lib.c

@@ -1,7 +1,6 @@
 /* -*-comment-start: "//";comment-end:""-*-
  * GNU Mes --- Maxwell Equations of Software
  * Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
- * Copyright © 2021 W. J. van der Laan <laanwj@protonmail.com>
  *
  * This file is part of GNU Mes.
  *
@@ -19,6 +18,12 @@
  * along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
  */
 
+/** Commentary:
+    Scheme library functions not used by the eval/apply core.
+ */
+
+/** Code: */
+
 #include "mes/lib.h"
 #include "mes/mes.h"
 
@@ -48,97 +53,6 @@ cdr_ (SCM x)
   return make_number (d);
 }
 
-SCM
-exit_ (SCM x)                   /*:((name . "exit")) */
-{
-  assert_msg (TYPE (x) == TNUMBER, "TYPE (x) == TNUMBER");
-  exit (VALUE (x));
-}
-
-SCM
-frame_printer (SCM frame)
-{
-  fdputs ("#<", __stdout);
-  display_ (struct_ref_ (frame, 2));
-  fdputc (' ', __stdout);
-  fdputs ("procedure: ", __stdout);
-  display_ (struct_ref_ (frame, 3));
-  fdputc ('>', __stdout);
-}
-
-SCM
-make_frame_type ()              /*:((internal)) */
-{
-  SCM record_type = cell_symbol_record_type;    // FIXME
-  SCM fields = cell_nil;
-  fields = cons (cell_symbol_procedure, fields);
-  fields = cons (fields, cell_nil);
-  fields = cons (cell_symbol_frame, fields);
-  return make_struct (record_type, fields, cell_unspecified);
-}
-
-SCM
-make_frame (SCM stack, long index)
-{
-  SCM frame_type = make_frame_type ();
-  long array_index = 0;
-  SCM procedure = 0;
-  if (index != 0)
-    {
-      array_index = (STACK_SIZE - (index * FRAME_SIZE));
-      procedure = g_stack_array[array_index + FRAME_PROCEDURE];
-    }
-  if (procedure == 0)
-    procedure = cell_f;
-  SCM values = cell_nil;
-  values = cons (procedure, values);
-  values = cons (cell_symbol_frame, values);
-  return make_struct (frame_type, values, cstring_to_symbol ("frame-printer"));
-}
-
-SCM
-make_stack_type ()              /*:((internal)) */
-{
-  SCM record_type = cell_symbol_record_type;    // FIXME
-  SCM fields = cell_nil;
-  fields = cons (cstring_to_symbol ("frames"), fields);
-  fields = cons (fields, cell_nil);
-  fields = cons (cell_symbol_stack, fields);
-  return make_struct (record_type, fields, cell_unspecified);
-}
-
-SCM
-make_stack (SCM stack)          /*:((arity . n)) */
-{
-  SCM stack_type = make_stack_type ();
-  long size = (STACK_SIZE - g_stack) / FRAME_SIZE;
-  SCM frames = make_vector__ (size);
-  long i;
-  for (i = 0; i < size; i = i + 1)
-    {
-      SCM frame = make_frame (stack, i);
-      vector_set_x_ (frames, i, frame);
-    }
-  SCM values = cell_nil;
-  values = cons (frames, values);
-  values = cons (cell_symbol_stack, values);
-  return make_struct (stack_type, values, cell_unspecified);
-}
-
-SCM
-stack_length (SCM stack)
-{
-  SCM frames = struct_ref_ (stack, 3);
-  return vector_length (frames);
-}
-
-SCM
-stack_ref (SCM stack, SCM index)
-{
-  SCM frames = struct_ref_ (stack, 3);
-  return vector_ref (frames, index);
-}
-
 SCM
 xassq (SCM x, SCM a)            /* For speed in core. */
 {
@@ -211,8 +125,8 @@ equal2:
       long i;
       for (i = 0; i < LENGTH (a); i = i + 1)
         {
-          SCM ai = VECTOR (a) + i;
+          SCM ai = cell_ref (VECTOR (a), i);
-          SCM bi = VECTOR (b) + i;
+          SCM bi = cell_ref (VECTOR (b), i);
           if (TYPE (ai) == TREF)
             ai = REF (ai);
           if (TYPE (bi) == TREF)

src/posix.c

@@ -33,6 +33,13 @@
 #include <sys/wait.h>
 #include <unistd.h>
 
+SCM
+exit_ (SCM x)                   /*:((name . "exit")) */
+{
+  assert_msg (TYPE (x) == TNUMBER, "TYPE (x) == TNUMBER");
+  exit (VALUE (x));
+}
+
 int
 peekchar ()
 {

src/stack.c

@@ -0,0 +1,107 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+ * Copyright © 2021 W. J. van der Laan <laanwj@protonmail.com>
+ *
+ * This file is part of GNU Mes.
+ *
+ * GNU Mes is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 3 of the License, or (at
+ * your option) any later version.
+ *
+ * GNU Mes is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "mes/lib.h"
+#include "mes/mes.h"
+
+#include <stdlib.h>
+
+SCM
+frame_printer (SCM frame)
+{
+  fdputs ("#<", __stdout);
+  display_ (struct_ref_ (frame, 2));
+  fdputc (' ', __stdout);
+  fdputs ("procedure: ", __stdout);
+  display_ (struct_ref_ (frame, 3));
+  fdputc ('>', __stdout);
+}
+
+SCM
+make_frame_type ()              /*:((internal)) */
+{
+  SCM fields = cell_nil;
+  fields = cons (cell_symbol_procedure, fields);
+  fields = cons (fields, cell_nil);
+  fields = cons (cell_symbol_frame, fields);
+  return make_struct (cell_symbol_record_type, fields, cell_unspecified);
+}
+
+SCM
+make_frame (SCM stack, long index)
+{
+  SCM frame_type = make_frame_type ();
+  long array_index = 0;
+  SCM procedure = 0;
+  if (index != 0)
+    {
+      array_index = (STACK_SIZE - (index * FRAME_SIZE));
+      procedure = g_stack_array[array_index + FRAME_PROCEDURE];
+    }
+  if (procedure == 0)
+    procedure = cell_f;
+  SCM values = cell_nil;
+  values = cons (procedure, values);
+  values = cons (cell_symbol_frame, values);
+  return make_struct (frame_type, values, cstring_to_symbol ("frame-printer"));
+}
+
+SCM
+make_stack_type ()              /*:((internal)) */
+{
+  SCM fields = cell_nil;
+  fields = cons (cstring_to_symbol ("frames"), fields);
+  fields = cons (fields, cell_nil);
+  fields = cons (cell_symbol_stack, fields);
+  return make_struct (cell_symbol_record_type, fields, cell_unspecified);
+}
+
+SCM
+make_stack (SCM stack)          /*:((arity . n)) */
+{
+  SCM stack_type = make_stack_type ();
+  long size = (STACK_SIZE - g_stack) / FRAME_SIZE;
+  SCM frames = make_vector__ (size);
+  long i;
+  for (i = 0; i < size; i = i + 1)
+    {
+      SCM frame = make_frame (stack, i);
+      vector_set_x_ (frames, i, frame);
+    }
+  SCM values = cell_nil;
+  values = cons (frames, values);
+  values = cons (cell_symbol_stack, values);
+  return make_struct (stack_type, values, cell_unspecified);
+}
+
+SCM
+stack_length (SCM stack)
+{
+  SCM frames = struct_ref_ (stack, 3);
+  return vector_length (frames);
+}
+
+SCM
+stack_ref (SCM stack, SCM index)
+{
+  SCM frames = struct_ref_ (stack, 3);
+  return vector_ref (frames, index);
+}