remove c impls of ir/er macros
This commit is contained in:
Yuichi Nishiwaki
parent
c0b83759a8
commit
f4d68d691b
|
|
@ -92,6 +92,14 @@
|
|||
(dictionary-set! cache atom id)
|
||||
id)))))))
|
||||
|
||||
(define (sc-macro-transformer f)
|
||||
(lambda (expr use-env mac-env)
|
||||
(make-syntactic-closure mac-env '() (f expr use-env))))
|
||||
|
||||
(define (rsc-macro-transformer f)
|
||||
(lambda (expr use-env mac-env)
|
||||
(make-syntactic-closure use-env '() (f expr mac-env))))
|
||||
|
||||
(define (er-macro-transformer f)
|
||||
(lambda (expr use-env mac-env)
|
||||
|
||||
|
|
@ -158,16 +166,10 @@
|
|||
|
||||
(unwrap (f (wrap expr) inject compare))))
|
||||
|
||||
(define (sc-macro-transformer f)
|
||||
(lambda (expr use-env mac-env)
|
||||
(make-syntactic-closure mac-env '() (f expr use-env))))
|
||||
|
||||
(define (rsc-macro-transformer f)
|
||||
(lambda (expr use-env mac-env)
|
||||
(make-syntactic-closure use-env '() (f expr mac-env))))
|
||||
|
||||
(export sc-macro-transformer
|
||||
rsc-macro-transformer))
|
||||
rsc-macro-transformer
|
||||
er-macro-transformer
|
||||
ir-macro-transformer))
|
||||
|
||||
;;; core syntaces
|
||||
(define-library (picrin core-syntax)
|
||||
|
|
|
|||
218
src/macro.c
218
src/macro.c
|
|
@ -724,222 +724,6 @@ pic_macro_identifier_eq_p(pic_state *pic)
|
|||
return pic_bool_value(sc_identifier_eq_p(pic, e1, x, e2, y));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
er_macro_rename(pic_state *pic)
|
||||
{
|
||||
pic_sym sym;
|
||||
struct pic_senv *mac_env;
|
||||
struct pic_dict *cxt;
|
||||
|
||||
pic_get_args(pic, "m", &sym);
|
||||
|
||||
mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
|
||||
cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
|
||||
|
||||
return pic_sym_value(make_identifier(pic, sym, mac_env, cxt));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
er_macro_compare(pic_state *pic)
|
||||
{
|
||||
pic_value a, b;
|
||||
struct pic_senv *use_env;
|
||||
pic_sym m, n;
|
||||
struct pic_dict *cxt;
|
||||
|
||||
pic_get_args(pic, "oo", &a, &b);
|
||||
|
||||
if (! pic_sym_p(a) || ! pic_sym_p(b))
|
||||
return pic_false_value(); /* should be an error? */
|
||||
|
||||
use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
|
||||
cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
|
||||
|
||||
m = make_identifier(pic, pic_sym(a), use_env, cxt);
|
||||
n = make_identifier(pic, pic_sym(b), use_env, cxt);
|
||||
|
||||
return pic_bool_value(m == n);
|
||||
}
|
||||
|
||||
static pic_value
|
||||
er_macro_call(pic_state *pic)
|
||||
{
|
||||
pic_value expr, use_env, mac_env;
|
||||
struct pic_proc *rename, *compare, *cb;
|
||||
struct pic_dict *cxt;
|
||||
|
||||
pic_get_args(pic, "ooo", &expr, &use_env, &mac_env);
|
||||
|
||||
if (! pic_senv_p(use_env)) {
|
||||
pic_error(pic, "unexpected type of argument 1");
|
||||
}
|
||||
if (! pic_senv_p(mac_env)) {
|
||||
pic_error(pic, "unexpected type of argument 3");
|
||||
}
|
||||
|
||||
cxt = pic_dict_new(pic);
|
||||
|
||||
rename = pic_proc_new(pic, er_macro_rename, "<er-macro-renamer>");
|
||||
pic_proc_cv_init(pic, rename, 3);
|
||||
pic_proc_cv_set(pic, rename, 0, use_env);
|
||||
pic_proc_cv_set(pic, rename, 1, mac_env);
|
||||
pic_proc_cv_set(pic, rename, 2, pic_obj_value(cxt));
|
||||
|
||||
compare = pic_proc_new(pic, er_macro_compare, "<er-macro-comparator>");
|
||||
pic_proc_cv_init(pic, compare, 3);
|
||||
pic_proc_cv_set(pic, compare, 0, use_env);
|
||||
pic_proc_cv_set(pic, compare, 1, mac_env);
|
||||
pic_proc_cv_set(pic, compare, 2, pic_obj_value(cxt));
|
||||
|
||||
cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
|
||||
|
||||
return pic_apply3(pic, cb, expr, pic_obj_value(rename), pic_obj_value(compare));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_macro_er_macro_transformer(pic_state *pic)
|
||||
{
|
||||
struct pic_proc *cb, *proc;
|
||||
|
||||
pic_get_args(pic, "l", &cb);
|
||||
|
||||
proc = pic_proc_new(pic, er_macro_call, "<er-macro-procedure>");
|
||||
pic_proc_cv_init(pic, proc, 1);
|
||||
pic_proc_cv_set(pic, proc, 0, pic_obj_value(cb));
|
||||
|
||||
return pic_obj_value(proc);
|
||||
}
|
||||
|
||||
static pic_value
|
||||
ir_macro_inject(pic_state *pic)
|
||||
{
|
||||
pic_sym sym;
|
||||
struct pic_senv *use_env;
|
||||
struct pic_dict *cxt;
|
||||
|
||||
pic_get_args(pic, "m", &sym);
|
||||
|
||||
use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
|
||||
cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
|
||||
|
||||
return pic_sym_value(make_identifier(pic, sym, use_env, cxt));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
ir_macro_compare(pic_state *pic)
|
||||
{
|
||||
pic_value a, b;
|
||||
struct pic_senv *mac_env;
|
||||
pic_sym m, n;
|
||||
struct pic_dict *cxt;
|
||||
|
||||
pic_get_args(pic, "oo", &a, &b);
|
||||
|
||||
if (! pic_sym_p(a) || ! pic_sym_p(b))
|
||||
return pic_false_value(); /* should be an error? */
|
||||
|
||||
mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
|
||||
cxt = pic_dict_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 2));
|
||||
|
||||
m = make_identifier(pic, pic_sym(a), mac_env, cxt);
|
||||
n = make_identifier(pic, pic_sym(b), mac_env, cxt);
|
||||
|
||||
return pic_bool_value(m == n);
|
||||
}
|
||||
|
||||
static pic_value
|
||||
ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, struct pic_dict *cxt, pic_value *ir)
|
||||
{
|
||||
if (pic_sym_p(expr)) {
|
||||
pic_value r;
|
||||
r = pic_sym_value(make_identifier(pic, pic_sym(expr), use_env, cxt));
|
||||
*ir = pic_acons(pic, r, expr, *ir);
|
||||
return r;
|
||||
}
|
||||
else if (pic_pair_p(expr)) {
|
||||
return pic_cons(pic,
|
||||
ir_macro_wrap(pic, pic_car(pic, expr), use_env, cxt, ir),
|
||||
ir_macro_wrap(pic, pic_cdr(pic, expr), use_env, cxt, ir));
|
||||
}
|
||||
else {
|
||||
return expr;
|
||||
}
|
||||
}
|
||||
|
||||
static pic_value
|
||||
ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, struct pic_dict *cxt, pic_value *ir)
|
||||
{
|
||||
if (pic_sym_p(expr)) {
|
||||
pic_value r;
|
||||
if (pic_test(r = pic_assq(pic, expr, *ir))) {
|
||||
return pic_cdr(pic, r);
|
||||
}
|
||||
return pic_sym_value(make_identifier(pic, pic_sym(expr), mac_env, cxt));
|
||||
}
|
||||
else if (pic_pair_p(expr)) {
|
||||
return pic_cons(pic,
|
||||
ir_macro_unwrap(pic, pic_car(pic, expr), mac_env, cxt, ir),
|
||||
ir_macro_unwrap(pic, pic_cdr(pic, expr), mac_env, cxt, ir));
|
||||
}
|
||||
else {
|
||||
return expr;
|
||||
}
|
||||
}
|
||||
|
||||
static pic_value
|
||||
ir_macro_call(pic_state *pic)
|
||||
{
|
||||
pic_value expr, use_env, mac_env;
|
||||
struct pic_proc *inject, *compare, *cb;
|
||||
struct pic_dict *cxt;
|
||||
pic_value ir = pic_nil_value();
|
||||
|
||||
pic_get_args(pic, "ooo", &expr, &use_env, &mac_env);
|
||||
|
||||
if (! pic_senv_p(use_env)) {
|
||||
pic_error(pic, "unexpected type of argument 1");
|
||||
}
|
||||
if (! pic_senv_p(mac_env)) {
|
||||
pic_error(pic, "unexpected type of argument 3");
|
||||
}
|
||||
|
||||
cxt = pic_dict_new(pic);
|
||||
|
||||
inject = pic_proc_new(pic, ir_macro_inject, "<ir-macro-injecter>");
|
||||
pic_proc_cv_init(pic, inject, 3);
|
||||
pic_proc_cv_set(pic, inject, 0, use_env);
|
||||
pic_proc_cv_set(pic, inject, 1, mac_env);
|
||||
pic_proc_cv_set(pic, inject, 2, pic_obj_value(cxt));
|
||||
|
||||
compare = pic_proc_new(pic, ir_macro_compare, "<ir-macro-comparator>");
|
||||
pic_proc_cv_init(pic, compare, 3);
|
||||
pic_proc_cv_set(pic, compare, 0, use_env);
|
||||
pic_proc_cv_set(pic, compare, 1, mac_env);
|
||||
pic_proc_cv_set(pic, compare, 2, pic_obj_value(cxt));
|
||||
|
||||
cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
|
||||
|
||||
expr = ir_macro_wrap(pic, expr, pic_senv_ptr(use_env), cxt, &ir);
|
||||
expr = pic_apply3(pic, cb, expr, pic_obj_value(inject), pic_obj_value(compare));
|
||||
expr = ir_macro_unwrap(pic, expr, pic_senv_ptr(mac_env), cxt, &ir);
|
||||
|
||||
return expr;
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_macro_ir_macro_transformer(pic_state *pic)
|
||||
{
|
||||
struct pic_proc *cb, *proc;
|
||||
|
||||
pic_get_args(pic, "l", &cb);
|
||||
|
||||
proc = pic_proc_new(pic, ir_macro_call, "<ir-macro-procedure>");
|
||||
pic_proc_cv_init(pic, proc, 1);
|
||||
pic_proc_cv_set(pic, proc, 0, pic_obj_value(cb));
|
||||
|
||||
return pic_obj_value(proc);
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_macro_make_identifier(pic_state *pic)
|
||||
{
|
||||
|
|
@ -966,8 +750,6 @@ pic_init_macro(pic_state *pic)
|
|||
pic_defun(pic, "make-syntactic-closure", pic_macro_make_sc);
|
||||
pic_defun(pic, "identifier?", pic_macro_identifier_p);
|
||||
pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p);
|
||||
pic_defun(pic, "er-macro-transformer", pic_macro_er_macro_transformer);
|
||||
pic_defun(pic, "ir-macro-transformer", pic_macro_ir_macro_transformer);
|
||||
pic_defun(pic, "make-identifier", pic_macro_make_identifier);
|
||||
}
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue