From 01d658a35610e8b0a34d02ecb091b50b957a4402 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Mon, 4 Apr 2022 10:49:06 -0600 Subject: [PATCH] core: Make symbol lookup extensible. * src/module.c (set_current_module): New function. (module_variable): Remove function. (module_define_x): Remove function. (current_module_variable): New function. * src/eval-apply.c (lookup_binding): Replace 'module_variable' with 'current_module_variable'; add the 'define_p' argument. (set_x): Adjust for 'define_p'. (lookup_value): Likewise. (expand_variable_): Likewise. (eval_apply): When evaluating defines, replace 'module_define_x' with 'lookup_binding' with 'define_p' set. * src/gc.c (gc_init)[!__M2_PLANET__]: Double ARENA_SIZE. * include/mes/constants.h (MODULE_EVAL_CLOSURE): New constant. * include/mes/mes.h (current_module_variable): New declaration. (current_module_define_x): New declaration. * include/mes/builtins.h (set_current_module): New declaration. (lookup_binding): Declare the 'define_p' argument. (module_variable): Remove declaration. (module_define_x): Remove declaration. * src/builtins.c (mes_builtins): Register 'set-current-module'; remove 'module-variable' and 'module-define!'. * mes/module/boot-0.scm (defined?): Do not use 'module-variable'. * mes/module/boot-00.scm (defined?): Likewise. * mes/module/boot-01.scm (defined?): Likewise. * mes/module/boot-02.scm (defined?): Likewise. * mes/module/boot-03.scm (defined?): Likewise. * scaffold/boot/60-let-syntax-expanded.scm (defined?): Likewise. * mes/module/mes/fluids.mes (make-fluid): Do not use 'module-define!', and wrap fluids in a variable record. * tests/macro.test (make-fluid): Likewise. Co-authored-by: Jan (janneke) Nieuwenhuizen --- include/mes/builtins.h | 3 +- include/mes/constants.h | 3 ++ include/mes/mes.h | 3 +- mes/module/mes/boot-0.scm | 2 +- mes/module/mes/boot-00.scm | 2 +- mes/module/mes/boot-01.scm | 2 +- mes/module/mes/boot-02.scm | 2 +- mes/module/mes/boot-03.scm | 2 +- mes/module/mes/fluids.mes | 15 +++++---- scaffold/boot/60-let-syntax-expanded.scm | 2 +- src/builtins.c | 3 +- src/eval-apply.c | 22 ++++++------- src/gc.c | 2 +- src/module.c | 41 ++++++++++++++++++++---- tests/macro.test | 14 ++++---- 15 files changed, 73 insertions(+), 45 deletions(-) diff --git a/include/mes/builtins.h b/include/mes/builtins.h index bcded4d2..64d60ae7 100644 --- a/include/mes/builtins.h +++ b/include/mes/builtins.h @@ -101,10 +101,9 @@ struct scm *lognot (struct scm *x); struct scm *logxor (struct scm *x); struct scm *ash (struct scm *n, struct scm *count); /* src/module.c */ -struct scm *module_variable (struct scm *module, struct scm *name); -struct scm *module_define_x (struct scm *module, struct scm *name, struct scm *value); struct scm *initial_module (); struct scm *current_module (); +struct scm *set_current_module (struct scm *module); /* src/posix.c */ struct scm *abort_ (); struct scm *exit_ (struct scm *x); diff --git a/include/mes/constants.h b/include/mes/constants.h index b3557ca6..24415a16 100644 --- a/include/mes/constants.h +++ b/include/mes/constants.h @@ -73,6 +73,9 @@ // CONSTANT FRAME_PROCEDURE 4 #define FRAME_PROCEDURE 4 +// CONSTANT MODULE_EVAL_CLOSURE 6 +#define MODULE_EVAL_CLOSURE 6 + // CONSTANT STDIN 0 // CONSTANT STDOUT 1 // CONSTANT STDERR 2 diff --git a/include/mes/mes.h b/include/mes/mes.h index db1e2d47..361e8ef9 100644 --- a/include/mes/mes.h +++ b/include/mes/mes.h @@ -131,10 +131,11 @@ struct scm *builtin_name (struct scm *builtin); struct scm *cstring_to_list (char const *s); struct scm *cstring_to_symbol (char const *s); struct scm *cell_ref (struct scm *cell, long index); +struct scm *current_module_variable (struct scm *name, struct scm *define_p); struct scm *fdisplay_ (struct scm *, int, int); struct scm *init_symbols (); struct scm *init_time (struct scm *a); -struct scm *lookup_binding (struct scm *name); +struct scm *lookup_binding (struct scm *name, struct scm *define_p); struct scm *lookup_value (struct scm *name); struct scm *make_builtin_type (); struct scm *make_bytes (char const *s, size_t length); diff --git a/mes/module/mes/boot-0.scm b/mes/module/mes/boot-0.scm index 6af3b850..121b3896 100644 --- a/mes/module/mes/boot-0.scm +++ b/mes/module/mes/boot-0.scm @@ -31,7 +31,7 @@ (define mes %version) (define (defined? x) - (module-variable (current-environment) x)) + (core:hashq-ref (initial-module) x #f)) (define (cond-expand-expander clauses) (if (defined? (car (car clauses))) diff --git a/mes/module/mes/boot-00.scm b/mes/module/mes/boot-00.scm index 274199d4..d4371680 100644 --- a/mes/module/mes/boot-00.scm +++ b/mes/module/mes/boot-00.scm @@ -20,7 +20,7 @@ (define mes %version) (define (defined? x) - (module-variable (current-environment) x)) + (core:hashq-ref (initial-module) x #f)) (define (cond-expand-expander clauses) (if (defined? (car (car clauses))) diff --git a/mes/module/mes/boot-01.scm b/mes/module/mes/boot-01.scm index ce6e82f9..b275e7be 100644 --- a/mes/module/mes/boot-01.scm +++ b/mes/module/mes/boot-01.scm @@ -20,7 +20,7 @@ (define mes %version) (define (defined? x) - (module-variable (current-environment) x)) + (core:hashq-ref (initial-module) x #f)) (define (cond-expand-expander clauses) (if (defined? (car (car clauses))) diff --git a/mes/module/mes/boot-02.scm b/mes/module/mes/boot-02.scm index e89ebe63..e5f0105f 100644 --- a/mes/module/mes/boot-02.scm +++ b/mes/module/mes/boot-02.scm @@ -30,7 +30,7 @@ (define mes %version) (define (defined? x) - (module-variable (current-environment) x)) + (core:hashq-ref (initial-module) x #f)) (define (cond-expand-expander clauses) (if (defined? (car (car clauses))) diff --git a/mes/module/mes/boot-03.scm b/mes/module/mes/boot-03.scm index 566cb5e5..962dd80c 100644 --- a/mes/module/mes/boot-03.scm +++ b/mes/module/mes/boot-03.scm @@ -30,7 +30,7 @@ (define mes %version) (define (defined? x) - (module-variable (current-environment) x)) + (core:hashq-ref (initial-module) x #f)) (define (cond-expand-expander clauses) (if (defined? (car (car clauses))) diff --git a/mes/module/mes/fluids.mes b/mes/module/mes/fluids.mes index ca36d31c..41669f84 100644 --- a/mes/module/mes/fluids.mes +++ b/mes/module/mes/fluids.mes @@ -27,14 +27,15 @@ (define-macro (make-fluid . default) ((lambda (fluid) `(begin - (module-define! + (hashq-set! (initial-module) - ',fluid - ((lambda (v) - (lambda ( . rest) - (if (null? rest) v - (set! v (car rest))))) - ,(and (pair? default) (car default)))) + ',fluid + (make-variable + ((lambda (v) + (lambda ( . rest) + (if (null? rest) v + (set! v (car rest))))) + ,(and (pair? default) (car default))))) ',fluid)) (symbol-append 'fluid: (gensym)))) diff --git a/scaffold/boot/60-let-syntax-expanded.scm b/scaffold/boot/60-let-syntax-expanded.scm index 47b44daa..415c4015 100644 --- a/scaffold/boot/60-let-syntax-expanded.scm +++ b/scaffold/boot/60-let-syntax-expanded.scm @@ -20,7 +20,7 @@ (define mes %version) (define (defined? x) - (module-variable (current-environment) x)) + (core:hashq-ref (initial-module) x #f)) (define (cond-expand-expander clauses) (if (defined? (car (car clauses))) diff --git a/src/builtins.c b/src/builtins.c index 528abbfe..ebb3d12d 100644 --- a/src/builtins.c +++ b/src/builtins.c @@ -211,10 +211,9 @@ mes_builtins (struct scm *a) /*:((internal)) */ a = init_builtin (builtin_type, "logxor", -1, &logxor, a); a = init_builtin (builtin_type, "ash", 2, &ash, a); /* src/module.c */ - a = init_builtin (builtin_type, "module-variable", 2, &module_variable, a); - a = init_builtin (builtin_type, "module-define!", 3, &module_define_x, a); a = init_builtin (builtin_type, "initial-module", 0, &initial_module, a); a = init_builtin (builtin_type, "current-module", 0, ¤t_module, a); + a = init_builtin (builtin_type, "set-current-module", 1, &set_current_module, a); /* src/posix.c */ a = init_builtin (builtin_type, "abort", 0, &abort_, a); a = init_builtin (builtin_type, "exit", 1, &exit_, a); diff --git a/src/eval-apply.c b/src/eval-apply.c index fe362bf2..8e7f0d78 100644 --- a/src/eval-apply.c +++ b/src/eval-apply.c @@ -129,7 +129,7 @@ set_x (struct scm *x, struct scm *e) if (x->type == TBINDING) binding = x; else - binding = lookup_binding (x); + binding = lookup_binding (x, cell_f); if (binding == cell_f) return error (cell_symbol_unbound_variable, x); @@ -205,15 +205,15 @@ push_cc (struct scm *p1, struct scm *p2, struct scm *a, struct scm *c) /*:((int } struct scm * -lookup_binding (struct scm *name) +lookup_binding (struct scm *name, struct scm *define_p) { struct scm *handle = assq (name, R0); if (handle != cell_f) return make_binding_ (handle, 1); - handle = module_variable (M0, name); - if (handle != cell_f) - return make_binding_ (handle, 0); + struct scm *variable = current_module_variable (name, define_p); + if (variable != cell_f) + return make_binding_ (cons (name, variable), 0); return cell_f; } @@ -221,7 +221,7 @@ lookup_binding (struct scm *name) struct scm * lookup_value (struct scm *name) { - struct scm *binding = lookup_binding (name); + struct scm *binding = lookup_binding (name, cell_f); if (binding != cell_f) { if (binding->lexical_p != 0) @@ -316,7 +316,7 @@ expand_variable_ (int top_p) /*:((internal)) */ && a != cell_symbol_current_environment && formal_p (a, R2) == 0) { - v = lookup_binding (a); + v = lookup_binding (a, cell_f); if (v != cell_f) R1->car = v; } @@ -677,11 +677,9 @@ eval: } else { - R2 = name; - entry = lookup_binding (name); - name = R2; - if (entry == cell_f) - module_define_x (M0, name, cell_f); + /* Ensure this name is bound in the current + module. */ + lookup_binding (name, cell_t); } } R2 = R1; diff --git a/src/gc.c b/src/gc.c index ab1edf5a..97ed7aae 100644 --- a/src/gc.c +++ b/src/gc.c @@ -57,7 +57,7 @@ gc_init () #if SYSTEM_LIBC ARENA_SIZE = 100000000; /* 2.3GiB */ #elif ! __M2_PLANET__ - ARENA_SIZE = 300000; /* 32b: 3MiB, 64b: 6 MiB */ + ARENA_SIZE = 600000; /* 32b: 6MiB, 64b: 12 MiB */ #else ARENA_SIZE = 20000000; #endif diff --git a/src/module.c b/src/module.c index 6535069c..1072a1f0 100644 --- a/src/module.c +++ b/src/module.c @@ -1,6 +1,7 @@ /* -*-comment-start: "//";comment-end:""-*- * GNU Mes --- Maxwell Equations of Software * Copyright © 2018,2019 Jan (janneke) Nieuwenhuizen + * Copyright © 2022 Timothy Sample * * This file is part of GNU Mes. * @@ -48,16 +49,42 @@ current_module () } struct scm * -module_variable (struct scm *module, struct scm *name) +set_current_module (struct scm *module) { - module = M0; - return hashq_get_handle (module, name); + struct scm *previous = M1; + M1 = module; + return previous; } struct scm * -module_define_x (struct scm *module, struct scm *name, struct scm *value) +current_module_variable (struct scm *name, struct scm *define_p) { - module = M0; - struct scm *var = make_variable (value); - return hashq_set_x (module, name, var); + struct scm *module = current_module (); + + /* When '(current-module)' is false, that means the module system is + not yet booted. In that case, we lookup variables in the initial + module hash table. */ + if (module == cell_f) + { + module = initial_module (); + struct scm *variable = hashq_ref_ (module, name, cell_f); + if (variable == cell_f && define_p != cell_f) + return hashq_set_x (module, name, make_variable (cell_undefined)); + else + return variable; + } + + /* The module system is booted. We can use the current module's + 'eval-closure' procedure. We take it on faith that whatever is in + 'M1' is a module. */ + struct scm *eval_closure = struct_ref_ (module, MODULE_EVAL_CLOSURE); + struct scm *args = cell_nil; + args = cons (define_p, args); + args = cons (name, args); + /* XXX: Calling 'apply' does not restore the registers properly. We + work around it here, but maybe it should be fixed in 'apply'. */ + gc_push_frame (); + struct scm *result = apply (eval_closure, args, cell_nil); + gc_pop_frame (); + return result; } diff --git a/tests/macro.test b/tests/macro.test index 03d82e53..e0b1f150 100755 --- a/tests/macro.test +++ b/tests/macro.test @@ -68,15 +68,15 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests (list 'begin (list - 'module-define! + 'hashq-set! (list 'initial-module) (list 'quote fluid) - (list - (lambda (v) - (lambda ( . rest) - (if (null? rest) v - (set! v (car rest))))) - (and (pair? default) (car default)))) + (list 'make-variable + (list (lambda (v) + (lambda ( . rest) + (if (null? rest) v + (set! v (car rest))))) + (and (pair? default) (car default))))) (list 'quote fluid))) (symbol-append 'fluid: (gensym))))