From 5edef591b7df82a689316463bafb4dd8bf6c6327 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Sat, 26 Mar 2022 22:40:54 -0600 Subject: [PATCH] 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 | 1 + build-aux/configure-lib.sh | 1 + build-aux/snarf.sh | 1 + include/mes/builtins.h | 6 +++ include/mes/mes.h | 2 + include/mes/symbols.h | 5 ++- kaem.run | 1 + mes/module/mes/scm.mes | 9 +++++ simple.make | 1 + src/builtins.c | 6 +++ src/gc.c | 2 + src/module.c | 4 ++ src/symbol.c | 1 + src/variable.c | 78 ++++++++++++++++++++++++++++++++++++++ tests/variable.test | 56 +++++++++++++++++++++++++++ 15 files changed, 172 insertions(+), 2 deletions(-) create mode 100644 src/variable.c create mode 100755 tests/variable.test diff --git a/build-aux/check-mes.sh b/build-aux/check-mes.sh index a58f1c1e..1365fcd4 100755 --- a/build-aux/check-mes.sh +++ b/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 diff --git a/build-aux/configure-lib.sh b/build-aux/configure-lib.sh index 609dcaff..91e38e05 100644 --- a/build-aux/configure-lib.sh +++ b/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 " diff --git a/build-aux/snarf.sh b/build-aux/snarf.sh index 782438aa..c28c9bbe 100755 --- a/build-aux/snarf.sh +++ b/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 diff --git a/include/mes/builtins.h b/include/mes/builtins.h index 35a47ce1..cbc5a02c 100644 --- a/include/mes/builtins.h +++ b/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); diff --git a/include/mes/mes.h b/include/mes/mes.h index 5c067a5d..8e02f936 100644 --- a/include/mes/mes.h +++ b/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); diff --git a/include/mes/symbols.h b/include/mes/symbols.h index 98cbac8c..6a323494 100644 --- a/include/mes/symbols.h +++ b/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 diff --git a/kaem.run b/kaem.run index 31355dc4..e6cdf690 100644 --- a/kaem.run +++ b/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 diff --git a/mes/module/mes/scm.mes b/mes/module/mes/scm.mes index e50e4332..d3478bf7 100644 --- a/mes/module/mes/scm.mes +++ b/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)) diff --git a/simple.make b/simple.make index 93b51e7e..01a7ff57 100644 --- a/simple.make +++ b/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 = \ diff --git a/src/builtins.c b/src/builtins.c index cb114457..d496fe4a 100644 --- a/src/builtins.c +++ b/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); diff --git a/src/gc.c b/src/gc.c index 5b7c08fe..29eb5d77 100644 --- a/src/gc.c +++ b/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; diff --git a/src/module.c b/src/module.c index aa647c8c..1d562dec 100644 --- a/src/module.c +++ b/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; diff --git a/src/symbol.c b/src/symbol.c index 9e6993ac..d95532a8 100644 --- a/src/symbol.c +++ b/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, ""); cell_type_bytes = init_symbol (g_symbol, TSYMBOL, ""); cell_type_char = init_symbol (g_symbol, TSYMBOL, ""); diff --git a/src/variable.c b/src/variable.c new file mode 100644 index 00000000..25b35b9c --- /dev/null +++ b/src/variable.c @@ -0,0 +1,78 @@ +/* -*-comment-start: "//";comment-end:""-*- + * GNU Mes --- Maxwell Equations of Software + * Copyright © Timothy Sample + * + * 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 . + */ + +#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 ("#', __stdout); + return cell_unspecified; +} diff --git a/tests/variable.test b/tests/variable.test new file mode 100755 index 00000000..7699b4c3 --- /dev/null +++ b/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 +;;; +;;; 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 . + +(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)