core: Implement Guile-style variables.

* src/variable.c: New file.
* simple.make (LIBMES_SOURCES): Add it.
* build-aux/configure-lib.sh (mes_SOURCES): Add it.
* build-aux/snarf.sh: Snarf it.
* kaem.run: Compile it.
* include/mes/builtins.h (make_variable): New function.
(variable_p): New function.
(variable_ref): New function.
(variable_set_x): New function.
(variable_printer): New function.
* src/builtins.c (mes_builtins): Register them.
* include/mes/mes.h (make_variable_type): New function.
(scm_variable_type): New variable.
* src/module.c (make_initial_module): Initialize it.
* src/gc.c (gc_flip, gc_): Keep track of it.
* include/mes/symbols.h (cell_symbol_variable): New variable.
(SYMBOL_MAX): Adjust accordingly.
* src/symbol.c (init_symbols): Initialize 'cell_symbol_variable'.
* mes/module/mes/scm.mes (make-undefined-variable): New procedure.
(variable-bound?): New procedure.
* tests/variable.test: New file.
* build-aux/check-mes.sh (TESTS): Add it.

build-aux/check-mes.sh

@@ -39,6 +39,7 @@ tests/cwv.test
 tests/math.test
 tests/vector.test
 tests/hash.test
+tests/variable.test
 tests/srfi-1.test
 tests/srfi-9.test
 tests/srfi-13.test

build-aux/configure-lib.sh

@@ -451,5 +451,6 @@ src/stack.c
 src/string.c
 src/struct.c
 src/symbol.c
+src/variable.c
 src/vector.c
 "

build-aux/snarf.sh

@@ -40,6 +40,7 @@ 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
+trace "SNARF$snarf  variable.c"   ${srcdest}build-aux/mes-snarf.scm src/variable.c
 trace "SNARF$snarf  vector.c"     ${srcdest}build-aux/mes-snarf.scm src/vector.c
 
 for i in src/*.symbols.h; do

include/mes/builtins.h

@@ -174,6 +174,12 @@ struct scm *make_struct (struct scm *type, struct scm *fields, struct scm *print
 struct scm *struct_length (struct scm *x);
 struct scm *struct_ref (struct scm *x, struct scm *i);
 struct scm *struct_set_x (struct scm *x, struct scm *i, struct scm *e);
+/* src/variable.c */
+struct scm *make_variable (struct scm *var);
+struct scm *variable_p (struct scm *x);
+struct scm *variable_ref (struct scm *var);
+struct scm *variable_set_x (struct scm *var, struct scm *value);
+struct scm *variable_printer (struct scm *var);
 /* src/vector.c */
 struct scm *make_vector (struct scm *x);
 struct scm *vector_length (struct scm *x);

include/mes/mes.h

@@ -109,6 +109,7 @@ extern struct timeval *__gettimeofday_time;
 extern struct timespec *__get_internal_run_time_ts;
 
 extern struct scm *scm_hash_table_type;
+extern struct scm *scm_variable_type;
 
 struct scm *cast_charp_to_scmp (char const *i);
 struct scm **cast_charp_to_scmpp (char const *i);
@@ -148,6 +149,7 @@ struct scm *make_ref (struct scm *x);
 struct scm *make_string (char const *s, size_t length);
 struct scm *make_string0 (char const *s);
 struct scm *make_string_port (struct scm *x);
+struct scm *make_variable_type ();
 struct scm *make_vector_ (long k, struct scm *e);
 struct scm *mes_builtins (struct scm *a);
 struct scm *push_cc (struct scm *p1, struct scm *p2, struct scm *a, struct scm *c);

include/mes/symbols.h

@@ -114,6 +114,7 @@ extern struct scm *cell_symbol_compiler;
 extern struct scm *cell_symbol_arch;
 extern struct scm *cell_symbol_pmatch_car;
 extern struct scm *cell_symbol_pmatch_cdr;
+extern struct scm *cell_symbol_variable;
 extern struct scm *cell_type_bytes;
 extern struct scm *cell_type_char;
 extern struct scm *cell_type_closure;
@@ -136,8 +137,8 @@ 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 115
+#define SYMBOL_MAX 115
 
 // CONSTANT CELL_UNSPECIFIED 7
 #define CELL_UNSPECIFIED 7

kaem.run

@@ -110,6 +110,7 @@ M2-Planet                                       \
     -f src/string.c                             \
     -f src/struct.c                             \
     -f src/symbol.c                             \
+    -f src/variable.c                           \
     -f src/vector.c                             \
     -o m2/mes.M1
 

mes/module/mes/scm.mes

@@ -223,6 +223,15 @@
   ;;(hash-fold (lambda (key value x) (proc key value)) #f table)
   *unspecified*)
 
+
+;; Variable
+(define (make-undefined-variable)
+  (make-variable *undefined*))
+
+;; This should be 'variable-defined?', but this is Guile's name.
+(define (variable-bound? var)
+  (not (eq? (variable-ref var) *undefined*)))
+
 
 ;; Vector
 (define (vector . rest) (list->vector rest))

simple.make

@@ -62,6 +62,7 @@ LIBMES_SOURCES =				\
  src/stack.c					\
  src/struct.c					\
  src/symbol.c					\
+ src/variable.c					\
  src/vector.c
 
 MES_SOURCES =					\

src/builtins.c

@@ -284,6 +284,12 @@ mes_builtins (struct scm *a)            /*:((internal)) */
   a = init_builtin (builtin_type, "struct-length", 1, &struct_length, a);
   a = init_builtin (builtin_type, "struct-ref", 2, &struct_ref, a);
   a = init_builtin (builtin_type, "struct-set!", 3, &struct_set_x, a);
+  /* src/variable.c */
+  a = init_builtin (builtin_type, "make-variable", 1, &make_variable, a);
+  a = init_builtin (builtin_type, "variable?", 1, &variable_p, a);
+  a = init_builtin (builtin_type, "variable-ref", 1, &variable_ref, a);
+  a = init_builtin (builtin_type, "variable-set!", 2, &variable_set_x, a);
+  a = init_builtin (builtin_type, "variable-printer", 1, &variable_printer, a);
   /* src/vector.c */
   a = init_builtin (builtin_type, "make-vector", -1, &make_vector, a);
   a = init_builtin (builtin_type, "vector-length", 1, &vector_length, a);

src/gc.c

@@ -474,6 +474,7 @@ gc_flip ()
   g_macros = g_macros - dist;
   g_ports = g_ports - dist;
   scm_hash_table_type = scm_hash_table_type - dist;
+  scm_variable_type = scm_variable_type - dist;
   M0 = M0 - dist;
 
   long i;
@@ -646,6 +647,7 @@ gc_ ()
   g_macros = gc_copy (g_macros);
   g_ports = gc_copy (g_ports);
   scm_hash_table_type = gc_copy (scm_hash_table_type);
+  scm_variable_type = gc_copy (scm_variable_type);
   M0 = gc_copy (M0);
 
   long i;

src/module.c

@@ -42,6 +42,10 @@ make_initial_module (struct scm *a)     /*:((internal)) */
   struct scm *hash_table_type = scm_hash_table_type;
   a = acons (cell_symbol_hashq_table, hash_table_type, a);
 
+  make_variable_type ();
+  struct scm *variable_type = scm_variable_type;
+  a = acons (cell_symbol_variable, variable_type, a);
+
   struct scm *name = cons (cstring_to_symbol ("boot"), cell_nil);
   struct scm *globals = make_hash_table_ (0);
   struct scm *locals = cell_nil;

src/symbol.c

@@ -149,6 +149,7 @@ init_symbols_ ()                  /*:((internal)) */
   cell_symbol_arch = init_symbol (g_symbol, TSYMBOL, "%arch");
   cell_symbol_pmatch_car = init_symbol (g_symbol, TSYMBOL, "pmatch-car");
   cell_symbol_pmatch_cdr = init_symbol (g_symbol, TSYMBOL, "pmatch-cdr");
+  cell_symbol_variable = init_symbol (g_symbol, TSYMBOL, "<variable>");
 
   cell_type_bytes = init_symbol (g_symbol, TSYMBOL, "<cell:bytes>");
   cell_type_char = init_symbol (g_symbol, TSYMBOL, "<cell:char>");

src/variable.c

@@ -0,0 +1,78 @@
+/* -*-comment-start: "//";comment-end:""-*-
+ * GNU Mes --- Maxwell Equations of Software
+ * Copyright © Timothy Sample <samplet@ngyro.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"
+
+struct scm *
+make_variable_type ()            /*:((internal)) */
+{
+  if (scm_variable_type == 0)
+    {
+      struct scm *record_type = cell_symbol_record_type;
+      struct scm *fields = cell_nil;
+      fields = cons (cstring_to_symbol ("value"), fields);
+      fields = cons (fields, cell_nil);
+      fields = cons (cell_symbol_variable, fields);
+      scm_variable_type = make_struct (record_type, fields, cell_unspecified);
+    }
+  return scm_variable_type;
+}
+
+struct scm *
+make_variable (struct scm *value)
+{
+  struct scm *type = make_variable_type ();
+  struct scm *values = cell_nil;
+  values = cons (value, values);
+  values = cons (cell_symbol_variable, values);
+  return make_struct (type, values, cstring_to_symbol ("variable-printer"));
+}
+
+struct scm *
+variable_p (struct scm *x)
+{
+  struct scm *type = make_variable_type ();
+  if (x->type == TSTRUCT)
+    if (struct_ref_ (x, 0) == type)
+      return cell_t;
+  return cell_f;
+}
+
+struct scm *
+variable_ref (struct scm *var)
+{
+  return struct_ref_ (var, 3);
+}
+
+struct scm *
+variable_set_x (struct scm *var, struct scm *val)
+{
+  return struct_set_x_ (var, 3, val);
+}
+
+struct scm *
+variable_printer (struct scm *var)
+{
+  fdputs ("#<variable ", __stdout);
+  display_ (variable_ref (var));
+  fdputc ('>', __stdout);
+  return cell_unspecified;
+}

tests/variable.test

@@ -0,0 +1,56 @@
+#! /bin/sh
+# -*-scheme-*-
+exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests variable)' -s "$0" "$@"
+!#
+
+;;; -*-scheme-*-
+
+;;; GNU Mes --- Maxwell Equations of Software
+;;; Copyright © 2022 Timothy Sample <samplet@ngyro.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 <https://www.gnu.org/licenses/>.
+
+(define-module (tests variable)
+  #:use-module (mes test))
+
+(cond-expand
+ (mes
+  (mes-use-module (mes test)))
+ (else))
+
+(pass-if "make-variable and variable-ref"
+  (let* ((x (cons 'foo '()))
+         (v (make-variable x)))
+    (eq? x (variable-ref v))))
+
+(pass-if "variable-set!"
+  (let ((v (make-variable 'foo)))
+    (variable-set! v 'bar)
+    (eq? 'bar (variable-ref v))))
+
+(pass-if "make-undefined-variable and variable-bound?"
+  (let ((bound (make-variable #t))
+        (unbound (make-undefined-variable)))
+    (and (variable-bound? bound)
+         (not (variable-bound? unbound)))))
+
+(pass-if "bind an unbound variable"
+  (let ((v (make-undefined-variable)))
+    (and (not (variable-bound? v))
+         (begin (variable-set! v #t)
+                (variable-bound? v)))))
+
+(result 'report)