From 16934697f77a5384b23fdad03c75de0e8d79b0f2 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 14 Oct 2018 08:30:18 +0200 Subject: [PATCH] core: Add module indirection for variable lookup. * src/module.c (module_ref, module_variable): New function. * src/mes.c: Thoughout: Use them. (assq_ref_env): Remove. * mes/module/mes/boot-0.scm.in (defined?): Use module-variable. * mes/module/mes/boot-00.scm (defined?): Likewise. * mes/module/mes/boot-01.scm (defined?): Likewise. * mes/module/mes/boot-02.scm (defined?): Likewise. * scaffold/boot/53-closure-display.scm: Likewise. --- mes/module/mes/boot-0.scm.in | 2 +- mes/module/mes/boot-00.scm | 2 +- mes/module/mes/boot-01.scm | 2 +- mes/module/mes/boot-02.scm | 2 +- scaffold/boot/53-closure-display.scm | 2 +- scaffold/boot/60-let-syntax-expanded.scm | 18 +--------------- scaffold/boot/60-let-syntax.scm | 16 -------------- src/mes.c | 27 ++++++++---------------- src/module.c | 17 +++++++++++++++ 9 files changed, 32 insertions(+), 56 deletions(-) diff --git a/mes/module/mes/boot-0.scm.in b/mes/module/mes/boot-0.scm.in index f4cf991a..07034a24 100644 --- a/mes/module/mes/boot-0.scm.in +++ b/mes/module/mes/boot-0.scm.in @@ -30,7 +30,7 @@ (define mes %version) (define (defined? x) - (assq x (current-module))) + (module-variable (current-module) x)) (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 3c43c85c..9c85ccb5 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) - (assq x (current-module))) + (module-variable (current-module) x)) (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 086cb00b..319d02dc 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) - (assq x (current-module))) + (module-variable (current-module) x)) (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 b38ec924..0d521762 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) - (assq x (current-module))) + (module-variable (current-module) x)) (define (cond-expand-expander clauses) (if (defined? (car (car clauses))) diff --git a/scaffold/boot/53-closure-display.scm b/scaffold/boot/53-closure-display.scm index e1837c67..4c31a221 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 (assq 'x (current-module))))))))))) + (map car (cdr (core:cdr (core:car (core:cdr (cdr (module-variable (current-module) 'x)))))))))) (define (x t) #t) (define (xx x1 x2) diff --git a/scaffold/boot/60-let-syntax-expanded.scm b/scaffold/boot/60-let-syntax-expanded.scm index 4c66e11e..8f84943f 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) - (assq x (current-module))) + (module-variable (current-module) x)) (define (cond-expand-expander clauses) (if (defined? (car (car clauses))) @@ -139,14 +139,6 @@ (if (eq? x (car lst)) lst (memq x (cdr lst))))) -;; (cond-expand -;; (guile -;; (define closure identity) -;; (define body identity) -;; (define append2 append) -;; (define (core:apply f a m) (f a)) -;; ) -;; (mes (define 11) (define (symbol? x) (eq? (core:type x) )) @@ -163,12 +155,6 @@ (define (vector? x) (eq? (core:type x) )) - ;; (define (body x) - ;; (core:cdr (core:cdr (core:cdr (cdr (assq 'x (current-module))))))) - ;; (define (closure x) - ;; (map car (cdr (core:cdr (core:car (core:cdr (cdr (assq 'x (current-module))))))))) - ;; )) - (define (cons* . rest) (if (null? (cdr rest)) (car rest) (cons (car rest) (core:apply cons* (cdr rest) (current-module))))) @@ -183,9 +169,7 @@ (append2 (car rest) (apply append (cdr rest)))))) (define-macro (quasiquote x) - ;;(core:display-error "quasiquote:") (core:write-error x) (core:display-error "\n") (define (loop x) - ;;(core:display-error "loop:") (core:write-error x) (core:display-error "\n") (if (vector? x) (list 'list->vector (loop (vector->list x))) (if (not (pair? x)) (cons 'quote (cons x '())) (if (eq? (car x) 'quasiquote) (loop (loop (cadr x))) diff --git a/scaffold/boot/60-let-syntax.scm b/scaffold/boot/60-let-syntax.scm index b6619b68..4710a86a 100644 --- a/scaffold/boot/60-let-syntax.scm +++ b/scaffold/boot/60-let-syntax.scm @@ -52,14 +52,6 @@ (if (eq? x (car lst)) lst (memq x (cdr lst))))) -;; (cond-expand -;; (guile -;; (define closure identity) -;; (define body identity) -;; (define append2 append) -;; (define (core:apply f a m) (f a)) -;; ) -;; (mes (define (symbol? x) (eq? (core:type x) )) @@ -73,12 +65,6 @@ (define (vector? x) (eq? (core:type x) )) - ;; (define (body x) - ;; (core:cdr (core:cdr (core:cdr (cdr (assq 'x (current-module))))))) - ;; (define (closure x) - ;; (map car (cdr (core:cdr (core:car (core:cdr (cdr (assq 'x (current-module))))))))) - ;; )) - (define (cons* . rest) (if (null? (cdr rest)) (car rest) (cons (car rest) (core:apply cons* (cdr rest) (current-module))))) @@ -93,9 +79,7 @@ (append2 (car rest) (apply append (cdr rest)))))) (define-macro (quasiquote x) - ;;(core:display-error "quasiquote:") (core:write-error x) (core:display-error "\n") (define (loop x) - ;;(core:display-error "loop:") (core:write-error x) (core:display-error "\n") (if (vector? x) (list 'list->vector (loop (vector->list x))) (if (not (pair? x)) (cons 'quote (cons x '())) (if (eq? (car x) 'quasiquote) (loop (loop (cadr x))) diff --git a/src/mes.c b/src/mes.c index ebdb5a27..cd259e63 100644 --- a/src/mes.c +++ b/src/mes.c @@ -562,7 +562,7 @@ error (SCM key, SCM x) { #if !__MESC_MES__ SCM throw; - if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined) + if ((throw = module_ref (r0, cell_symbol_throw)) != cell_undefined) return apply (throw, cons (key, cons (x, cell_nil)), r0); #endif display_error_ (key); @@ -826,15 +826,6 @@ assq (SCM x, SCM a) return a != cell_nil ? CAR (a) : cell_f; } -SCM -assq_ref_env (SCM x, SCM a) -{ - x = assq (x, a); - if (x == cell_f) - return cell_undefined; - return CDR (x); -} - SCM set_car_x (SCM x, SCM e) { @@ -860,7 +851,7 @@ set_env_x (SCM x, SCM e, SCM a) if (TYPE (x) == TVARIABLE) p = VARIABLE (x); else - p = assert_defined (x, assq (x, a)); + p = assert_defined (x, module_variable (a, x)); if (TYPE (p) != TPAIR) error (cell_symbol_not_a_pair, cons (p, x)); return set_cdr_x (p, e); @@ -1009,7 +1000,7 @@ expand_variable_ (SCM x, SCM formals, int top_p) ///((internal)) && CAR (x) != cell_symbol_if // HMM && !formal_p (CAR (x), formals)) { - SCM v = assq (CAR (x), r0); + SCM v = module_variable (r0, CAR (x)); if (v != cell_f) CAR (x) = make_variable_ (v); } @@ -1275,7 +1266,7 @@ eval_apply () } else { - entry = assq (name, r0); + entry = module_variable (r0, name); if (entry == cell_f) { entry = cons (name, cell_f); @@ -1315,7 +1306,7 @@ eval_apply () } else if (global_p) { - entry = assq (name, r0); + entry = module_variable (r0, name); set_cdr_x (entry, r1); } else @@ -1324,7 +1315,7 @@ eval_apply () aa = cons (entry, cell_nil); set_cdr_x (aa, cdr (r0)); set_cdr_x (r0, aa); - cl = assq (cell_closure, r0); + cl = module_variable (r0, cell_closure); set_cdr_x (cl, aa); } r1 = cell_unspecified; @@ -1350,7 +1341,7 @@ eval_apply () r1 = cell_begin; goto vm_return; } - r1 = assert_defined (r1, assq_ref_env (r1, r0)); + r1 = assert_defined (r1, module_ref (r0, r1)); goto vm_return; } else if (t == TVARIABLE) @@ -1421,10 +1412,10 @@ eval_apply () && TYPE (CAR (r1)) == TSYMBOL && CAR (r1) != cell_symbol_begin && ((macro = assq (cell_symbol_portable_macro_expand, g_macros)) != cell_f) - && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined) + && ((expanders = module_ref (r0, cell_symbol_sc_expander_alist)) != cell_undefined) && ((macro = assq (CAR (r1), expanders)) != cell_f)) { - sc_expand = assq_ref_env (cell_symbol_macro_expand, r0); + sc_expand = module_ref (r0, cell_symbol_macro_expand); r2 = r1; if (sc_expand != cell_undefined && sc_expand != cell_f) { diff --git a/src/module.c b/src/module.c index e7f244be..6c1d3489 100644 --- a/src/module.c +++ b/src/module.c @@ -38,3 +38,20 @@ make_initial_module (SCM a) SCM module = make_struct (module_type_name, values, cell_unspecified); return module; } + +SCM +module_ref (SCM module, SCM name) +{ + SCM x = module_variable (module, name); + if (x == cell_f) + return cell_undefined; + return CDR (x); +} + +SCM +module_variable (SCM module, SCM name) +{ + //SCM locals = struct_ref (module, 4); + SCM locals = module; + return assq (name, locals); +}