artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

core: Add module indirection for variable lookup.

Browse source 
* 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:
Jan Nieuwenhuizen 2018-10-14 08:30:18 +02:00
parent 79c1fe0466
commit 16934697f7
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
9 changed files with 32 additions and 56 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
mes/module/mes/boot-0.scm.in
View file

@ -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)))

2
mes/module/mes/boot-00.scm
View file

@ -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)))

2
mes/module/mes/boot-01.scm
View file

@ -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)))

2
mes/module/mes/boot-02.scm
View file

@ -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)))

2
scaffold/boot/53-closure-display.scm
View file

@ -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)

18
scaffold/boot/60-let-syntax-expanded.scm
View file

@ -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)))

16
scaffold/boot/60-let-syntax.scm
View file

@ -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
View file

@ -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
View file

@ -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);
}