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.
This commit is contained in:
parent
79c1fe0466
commit
16934697f7
|
@ -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)))
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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 <cell:symbol> 11)
|
||||
(define (symbol? x)
|
||||
(eq? (core:type x) <cell:symbol>))
|
||||
|
@ -163,12 +155,6 @@
|
|||
(define (vector? x)
|
||||
(eq? (core:type x) <cell:vector>))
|
||||
|
||||
;; (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)))
|
||||
|
|
|
@ -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) <cell:symbol>))
|
||||
|
||||
|
@ -73,12 +65,6 @@
|
|||
(define (vector? x)
|
||||
(eq? (core:type x) <cell:vector>))
|
||||
|
||||
;; (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)))
|
||||
|
|
27
src/mes.c
27
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)
|
||||
{
|
||||
|
|
17
src/module.c
17
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);
|
||||
}
|
||||
|
|
Loading…
Reference in a new issue