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 <janneke@gnu.org>
This commit is contained in:
parent
31b74c24bf
commit
01d658a356
|
@ -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);
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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))))
|
||||
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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;
|
||||
|
|
2
src/gc.c
2
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
|
||||
|
|
41
src/module.c
41
src/module.c
|
@ -1,6 +1,7 @@
|
|||
/* -*-comment-start: "//";comment-end:""-*-
|
||||
* GNU Mes --- Maxwell Equations of Software
|
||||
* Copyright © 2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||
* Copyright © 2022 Timothy Sample <samplet@ngyro.com>
|
||||
*
|
||||
* 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;
|
||||
}
|
||||
|
|
|
@ -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))))
|
||||
|
||||
|
|
Loading…
Reference in New Issue