From 9fa03f6182d934fe64b956c717843c8526220260 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Mon, 28 Mar 2022 16:11:22 -0600 Subject: [PATCH] core: Use variables for modules. This change introduces a 'lexical?' field for bindings (called 'lexical_p' and stored in the cdr of the binding cell). Non-lexical bindings handle variables transparently, while lexical bindings do not. * src/module.c (module_define_x): Wrap value in a variable. * include/mes/mes.h (scm): Add 'lexical_p' to the cdr union. * src/eval-apply.c (make_binding_): Add a 'lexical_p' argument. (lookup_handle): Remove function. (lookup_binding): Add function. (lookup_value): Use 'lookup_binding' and return the contents of variables that are not bound lexically. (set_env_x): Remove function. (set_x): New function. (expand_variable_): Use 'lookup_binding' in place of 'lookup_handle'. (eval_apply): Likewise; use 'set_x' in place of 'set_env_x'; and when evaluating a binding, return the contents of variables that are not bound lexically. * include/mes/builtins.h (set_env_x): Remove declaration. * src/builtins.c (mes_builtins): Do not register 'set-env!'. * scaffold/boot/53-closure-display.scm (closure)[mes]: Rewrite to avoid 'module-variable'. --- include/mes/builtins.h | 1 - include/mes/mes.h | 3 +- scaffold/boot/53-closure-display.scm | 2 +- src/builtins.c | 1 - src/eval-apply.c | 74 +++++++++++++++++----------- src/module.c | 3 +- 6 files changed, 51 insertions(+), 33 deletions(-) diff --git a/include/mes/builtins.h b/include/mes/builtins.h index cbc5a02c..556a1814 100644 --- a/include/mes/builtins.h +++ b/include/mes/builtins.h @@ -53,7 +53,6 @@ struct scm *write_port_ (struct scm *x, struct scm *p); struct scm *pairlis (struct scm *x, struct scm *y, struct scm *a); struct scm *set_car_x (struct scm *x, struct scm *e); struct scm *set_cdr_x (struct scm *x, struct scm *e); -struct scm *set_env_x (struct scm *x, struct scm *e, struct scm *a); struct scm *add_formals (struct scm *formals, struct scm *x); struct scm *eval_apply (); /* src/gc.c */ diff --git a/include/mes/mes.h b/include/mes/mes.h index 8e02f936..0e6a3178 100644 --- a/include/mes/mes.h +++ b/include/mes/mes.h @@ -50,6 +50,7 @@ struct scm long value; FUNCTION function; struct scm *vector; + long lexical_p; /* for bindings */ }; }; @@ -131,7 +132,7 @@ struct scm *cell_ref (struct scm *cell, long index); struct scm *fdisplay_ (struct scm *, int, int); struct scm *init_symbols (); struct scm *init_time (struct scm *a); -struct scm *lookup_handle (struct scm *name); +struct scm *lookup_binding (struct scm *name); 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/scaffold/boot/53-closure-display.scm b/scaffold/boot/53-closure-display.scm index 4c31a221..ddae2d2d 100644 --- a/scaffold/boot/53-closure-display.scm +++ b/scaffold/boot/53-closure-display.scm @@ -28,7 +28,7 @@ (if (null? lst) (list) (cons (f (car lst)) (map f (cdr lst))))) (define (closure x) - (map car (cdr (core:cdr (core:car (core:cdr (cdr (module-variable (current-module) 'x)))))))))) + (map car (cdr (core:cdr (core:car (core:cdr x)))))))) (define (x t) #t) (define (xx x1 x2) diff --git a/src/builtins.c b/src/builtins.c index d496fe4a..a4ed2c70 100644 --- a/src/builtins.c +++ b/src/builtins.c @@ -163,7 +163,6 @@ mes_builtins (struct scm *a) /*:((internal)) */ a = init_builtin (builtin_type, "pairlis", 3, &pairlis, a); a = init_builtin (builtin_type, "set-car!", 2, &set_car_x, a); a = init_builtin (builtin_type, "set-cdr!", 2, &set_cdr_x, a); - a = init_builtin (builtin_type, "set-env!", 3, &set_env_x, a); a = init_builtin (builtin_type, "add-formals", 2, &add_formals, a); a = init_builtin (builtin_type, "eval-apply", 0, &eval_apply, a); /* src/gc.c */ diff --git a/src/eval-apply.c b/src/eval-apply.c index 2bdc5817..d923d4c9 100644 --- a/src/eval-apply.c +++ b/src/eval-apply.c @@ -122,16 +122,24 @@ set_cdr_x (struct scm *x, struct scm *e) } struct scm * -set_env_x (struct scm *x, struct scm *e, struct scm *a) +set_x (struct scm *x, struct scm *e) { - struct scm *p; + struct scm *binding; + if (x->type == TBINDING) - p = x->binding; + binding = x; else - p = assert_defined (x, lookup_handle (x)); - if (p->type != TPAIR) - error (cell_symbol_not_a_pair, cons (p, x)); - return set_cdr_x (p, e); + binding = lookup_binding (x); + + if (binding == cell_f) + return error (cell_symbol_unbound_variable, x); + + if (binding->lexical_p != 0) + set_cdr_x (binding->binding, e); + else + variable_set_x (binding->binding->cdr, e); + + return cell_unspecified; } struct scm * @@ -150,9 +158,11 @@ make_closure_ (struct scm *args, struct scm *body, struct scm *a) /*:((int } struct scm * -make_binding_ (struct scm *handle) /*:((internal)) */ +make_binding_ (struct scm *handle, long lexical_p) /*:((internal)) */ { - return make_cell (TBINDING, handle, 0); + struct scm *binding = make_cell (TBINDING, handle, 0); + binding->lexical_p = lexical_p; + return binding; } struct scm * @@ -195,22 +205,30 @@ push_cc (struct scm *p1, struct scm *p2, struct scm *a, struct scm *c) /*:((int } struct scm * -lookup_handle (struct scm *name) +lookup_binding (struct scm *name) { struct scm *handle = assq (name, R0); - if (handle == cell_f) - { - handle = module_variable (M0, name); - } - return handle; + if (handle != cell_f) + return make_binding_ (handle, 1); + + handle = module_variable (M0, name); + if (handle != cell_f) + return make_binding_ (handle, 0); + + return cell_f; } struct scm * lookup_value (struct scm *name) { - struct scm *handle = lookup_handle (name); - if (handle != cell_f) - return handle->cdr; + struct scm *binding = lookup_binding (name); + if (binding != cell_f) + { + if (binding->lexical_p != 0) + return binding->binding->cdr; + else + return variable_ref (binding->binding->cdr); + } return cell_undefined; } @@ -295,9 +313,9 @@ expand_variable_ (struct scm *x, struct scm *formals, int top_p) /*:((int && a != cell_symbol_primitive_load && formal_p (x->car, formals) == 0) { - v = lookup_handle (a); + v = lookup_binding (a); if (v != cell_f) - x->car = make_binding_ (v); + x->car = v; } } x = x->cdr; @@ -607,7 +625,7 @@ eval: push_cc (R1->cdr->cdr->car, R1, R0, cell_vm_eval_set_x); goto eval; eval_set_x: - R1 = set_env_x (R2->cdr->car, R1, R0); + R1 = set_x (R2->cdr->car, R1); goto vm_return; } else if (c == cell_vm_macro_expand) @@ -645,7 +663,7 @@ eval: } else { - entry = lookup_handle (name); + entry = lookup_binding (name); if (entry == cell_f) module_define_x (M0, name, cell_f); } @@ -682,8 +700,7 @@ eval: } else if (global_p != 0) { - entry = lookup_handle (name); - set_cdr_x (entry, R1); + set_x (name, R1); } else { @@ -691,8 +708,7 @@ eval: aa = cons (entry, cell_nil); set_cdr_x (aa, cdr (R0)); set_cdr_x (R0, aa); - cl = lookup_handle (cell_closure); - set_cdr_x (cl, aa); + set_x (cell_closure, aa); } R1 = cell_unspecified; goto vm_return; @@ -721,8 +737,10 @@ eval: } else if (t == TBINDING) { - x = R1->binding; - R1 = x->cdr; + if (R1->lexical_p != 0) + R1 = R1->binding->cdr; + else + R1 = variable_ref (R1->binding->cdr); goto vm_return; } else if (t == TBROKEN_HEART) diff --git a/src/module.c b/src/module.c index 1d562dec..939a1de4 100644 --- a/src/module.c +++ b/src/module.c @@ -106,5 +106,6 @@ module_define_x (struct scm *module, struct scm *name, struct scm *value) { module = M0; struct scm *globals = struct_ref_ (module, 5); - return hashq_set_x (globals, name, value); + struct scm *var = make_variable (value); + return hashq_set_x (globals, name, var); }