diff --git a/build-aux/configure-lib.sh b/build-aux/configure-lib.sh index 7b3198a2..0182fbb4 100644 --- a/build-aux/configure-lib.sh +++ b/build-aux/configure-lib.sh @@ -450,5 +450,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 07609ddf..37da93c0 100644 --- a/include/mes/builtins.h +++ b/include/mes/builtins.h @@ -58,6 +58,7 @@ struct scm *add_formals (struct scm *formals, struct scm *x); struct scm *eval_apply (); /* src/gc.c */ struct scm *cons (struct scm *x, struct scm *y); +struct scm *make_variable (struct scm *var); struct scm *gc_check (); struct scm *gc (); /* src/hash.c */ @@ -169,6 +170,10 @@ 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 *variable_ref (struct scm *var); +struct scm *variable_set_x (struct scm *var, struct scm *value); +struct scm *variable_bound_p (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 a0fed07f..5311887f 100644 --- a/include/mes/mes.h +++ b/include/mes/mes.h @@ -160,6 +160,7 @@ size_t bytes_cells (size_t length); void assert_max_string (size_t i, char const *msg, char const *string); void assert_msg (int check, char *msg); void assert_number (char const *name, struct scm *x); +void assert_variable (long pos, struct scm *x); void copy_cell (struct scm *to, struct scm *from); void gc_ (); void gc_dump_arena (struct scm *cells, long size); diff --git a/kaem.run b/kaem.run index f7a554d0..5fc0924a 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 b119742b..8a49fd26 100644 --- a/mes/module/mes/scm.mes +++ b/mes/module/mes/scm.mes @@ -202,6 +202,11 @@ (define (hash-ref table key . rest) (core:hash-ref table key (and (pair? rest) (car rest)))) + +;; Variable +(define (make-undefined-variable) + (make-variable *undefined*)) + ;; Vector (define (vector . rest) (list->vector rest)) diff --git a/simple.make b/simple.make index e8415080..45230c1f 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 be5c1fb1..b9fdcc98 100644 --- a/src/builtins.c +++ b/src/builtins.c @@ -168,6 +168,7 @@ mes_builtins (struct scm *a) /*:((internal)) */ a = init_builtin (builtin_type, "eval-apply", 0, &eval_apply, a); /* src/gc.c */ a = init_builtin (builtin_type, "cons", 2, &cons, a); + a = init_builtin (builtin_type, "make-variable", 1, &make_variable, a); a = init_builtin (builtin_type, "gc-check", 0, &gc_check, a); a = init_builtin (builtin_type, "gc", 0, &gc, a); /* src/hash.c */ @@ -279,6 +280,10 @@ 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, "variable-ref", 1, &variable_ref, a); + a = init_builtin (builtin_type, "variable-set!", 2, &variable_set_x, a); + a = init_builtin (builtin_type, "variable-bound?", 1, &variable_bound_p, 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/eval-apply.c b/src/eval-apply.c index 19306452..597bde43 100644 --- a/src/eval-apply.c +++ b/src/eval-apply.c @@ -148,12 +148,6 @@ make_closure_ (struct scm *args, struct scm *body, struct scm *a) /*:((int return make_cell (TCLOSURE, cell_f, cons (cons (cell_circular, a), cons (args, body))); } -struct scm * -make_variable_ (struct scm *var) /*:((internal)) */ -{ - return make_cell (TVARIABLE, var, 0); -} - struct scm * macro_get_handle (struct scm *name) /*:((internal)) */ { @@ -277,7 +271,7 @@ expand_variable_ (struct scm *x, struct scm *formals, int top_p) /*:((int { v = module_variable (R0, a); if (v != cell_f) - x->car = make_variable_ (v); + x->car = make_variable (v); } } x = x->cdr; diff --git a/src/gc.c b/src/gc.c index 041779f3..ef046af3 100644 --- a/src/gc.c +++ b/src/gc.c @@ -298,6 +298,12 @@ make_string_port (struct scm *x) /*:((internal)) */ return make_pointer_cell (TPORT, -length__ (g_ports) - 2, x); } +struct scm * +make_variable (struct scm *var) +{ + return make_cell (TVARIABLE, var, 0); +} + void gc_init_news () { diff --git a/src/lib.c b/src/lib.c index 2be271f3..1fdc6b7b 100644 --- a/src/lib.c +++ b/src/lib.c @@ -216,3 +216,10 @@ assert_range (int assert, long i) error (cell_symbol_out_of_range, cons (cell_type_struct, cons (make_number (pos), cons (x, cell_nil)))); */ } + +void +assert_variable (long pos, struct scm *x) +{ + if (x->type != TVARIABLE) + error (cell_symbol_wrong_type_arg, cons (cell_type_struct, cons (make_number (pos), x))); +} diff --git a/src/variable.c b/src/variable.c new file mode 100644 index 00000000..39879076 --- /dev/null +++ b/src/variable.c @@ -0,0 +1,50 @@ +/* -*-comment-start: "//";comment-end:""-*- + * GNU Mes --- Maxwell Equations of Software + * Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen + * + * 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 * +variable_ref (struct scm *var) +{ + assert_variable (1, var); + struct scm *value = var->variable; + if (value == cell_undefined) + error (cell_symbol_unbound_variable, var); + return value; +} + +struct scm * +variable_set_x (struct scm *var, struct scm *value) +{ + assert_variable (1, var); + var->variable = value; + return cell_unspecified; +} + +struct scm * +variable_bound_p (struct scm *var) +{ + assert_variable (1, var); + struct scm *value = var->variable; + if (value != cell_undefined) + return cell_t; + return cell_f; +}