remove 'struct pic_macro'. define-syntax spec is changed.
This commit is contained in:
parent
592af901e2
commit
a3db19c1bf
|
@ -24,7 +24,8 @@ my $src = <<'EOL';
|
|||
val))))))
|
||||
|
||||
(define (er-macro-transformer f)
|
||||
(lambda (expr use-env mac-env)
|
||||
(lambda (mac-env)
|
||||
(lambda (expr use-env)
|
||||
|
||||
(define rename
|
||||
(memoize
|
||||
|
@ -38,7 +39,7 @@ my $src = <<'EOL';
|
|||
#f
|
||||
(identifier=? use-env x use-env y))))
|
||||
|
||||
(f expr rename compare)))
|
||||
(f expr rename compare))))
|
||||
|
||||
(define-syntax syntax-error
|
||||
(er-macro-transformer
|
||||
|
@ -50,7 +51,8 @@ my $src = <<'EOL';
|
|||
(lambda (expr r c)
|
||||
(list (r 'define-syntax) (cadr expr)
|
||||
(list (r 'lambda) '_
|
||||
(list (r 'error) "invalid use of auxiliary syntax"))))))
|
||||
(list (r 'lambda) '_
|
||||
(list (r 'error) "invalid use of auxiliary syntax")))))))
|
||||
|
||||
(define-auxiliary-syntax else)
|
||||
(define-auxiliary-syntax =>)
|
||||
|
@ -422,7 +424,8 @@ const char pic_boot[] =
|
|||
" val))))))\n"
|
||||
"\n"
|
||||
" (define (er-macro-transformer f)\n"
|
||||
" (lambda (expr use-env mac-env)\n"
|
||||
" (lambda (mac-env)\n"
|
||||
" (lambda (expr use-env)\n"
|
||||
"\n"
|
||||
" (define rename\n"
|
||||
" (memoize\n"
|
||||
|
@ -436,7 +439,7 @@ const char pic_boot[] =
|
|||
" #f\n"
|
||||
" (identifier=? use-env x use-env y))))\n"
|
||||
"\n"
|
||||
" (f expr rename compare)))\n"
|
||||
" (f expr rename compare))))\n"
|
||||
"\n"
|
||||
" (define-syntax syntax-error\n"
|
||||
" (er-macro-transformer\n"
|
||||
|
@ -448,7 +451,8 @@ const char pic_boot[] =
|
|||
" (lambda (expr r c)\n"
|
||||
" (list (r 'define-syntax) (cadr expr)\n"
|
||||
" (list (r 'lambda) '_\n"
|
||||
" (list (r 'error) \"invalid use of auxiliary syntax\"))))))\n"
|
||||
" (list (r 'lambda) '_\n"
|
||||
" (list (r 'error) \"invalid use of auxiliary syntax\")))))))\n"
|
||||
"\n"
|
||||
" (define-auxiliary-syntax else)\n"
|
||||
" (define-auxiliary-syntax =>)\n"
|
||||
|
|
|
@ -415,17 +415,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
|
|||
case PIC_TT_BLOB: {
|
||||
break;
|
||||
}
|
||||
case PIC_TT_MACRO: {
|
||||
struct pic_macro *mac = (struct pic_macro *)obj;
|
||||
|
||||
if (mac->proc) {
|
||||
gc_mark_object(pic, (struct pic_object *)mac->proc);
|
||||
}
|
||||
if (mac->senv) {
|
||||
gc_mark_object(pic, (struct pic_object *)mac->senv);
|
||||
}
|
||||
break;
|
||||
}
|
||||
case PIC_TT_SENV: {
|
||||
struct pic_senv *senv = (struct pic_senv *)obj;
|
||||
|
||||
|
@ -650,9 +639,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
|
|||
xh_destroy(&senv->map);
|
||||
break;
|
||||
}
|
||||
case PIC_TT_MACRO: {
|
||||
break;
|
||||
}
|
||||
case PIC_TT_LIB: {
|
||||
struct pic_lib *lib = (struct pic_lib *)obj;
|
||||
xh_destroy(&lib->exports);
|
||||
|
|
|
@ -16,15 +16,6 @@ struct pic_senv {
|
|||
struct pic_senv *up;
|
||||
};
|
||||
|
||||
struct pic_macro {
|
||||
PIC_OBJECT_HEADER
|
||||
struct pic_proc *proc;
|
||||
struct pic_senv *senv;
|
||||
};
|
||||
|
||||
#define pic_macro_p(v) (pic_type(v) == PIC_TT_MACRO)
|
||||
#define pic_macro_ptr(v) ((struct pic_macro *)pic_ptr(v))
|
||||
|
||||
#define pic_senv_p(v) (pic_type(v) == PIC_TT_SENV)
|
||||
#define pic_senv_ptr(v) ((struct pic_senv *)pic_ptr(v))
|
||||
|
||||
|
|
|
@ -125,7 +125,6 @@ enum pic_tt {
|
|||
PIC_TT_ERROR,
|
||||
PIC_TT_ENV,
|
||||
PIC_TT_SENV,
|
||||
PIC_TT_MACRO,
|
||||
PIC_TT_LIB,
|
||||
PIC_TT_IREP,
|
||||
PIC_TT_DATA,
|
||||
|
@ -266,8 +265,6 @@ pic_type_repr(enum pic_tt tt)
|
|||
return "proc";
|
||||
case PIC_TT_SENV:
|
||||
return "senv";
|
||||
case PIC_TT_MACRO:
|
||||
return "macro";
|
||||
case PIC_TT_LIB:
|
||||
return "lib";
|
||||
case PIC_TT_IREP:
|
||||
|
|
|
@ -47,18 +47,12 @@ pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *ren
|
|||
}
|
||||
|
||||
static void
|
||||
define_macro(pic_state *pic, pic_sym rename, struct pic_proc *proc, struct pic_senv *senv)
|
||||
define_macro(pic_state *pic, pic_sym rename, struct pic_proc *mac)
|
||||
{
|
||||
struct pic_macro *mac;
|
||||
|
||||
mac = (struct pic_macro *)pic_obj_alloc(pic, sizeof(struct pic_macro), PIC_TT_MACRO);
|
||||
mac->senv = senv;
|
||||
mac->proc = proc;
|
||||
|
||||
xh_put_int(&pic->macros, rename, &mac);
|
||||
}
|
||||
|
||||
static struct pic_macro *
|
||||
static struct pic_proc *
|
||||
find_macro(pic_state *pic, pic_sym rename)
|
||||
{
|
||||
xh_entry *e;
|
||||
|
@ -66,7 +60,7 @@ find_macro(pic_state *pic, pic_sym rename)
|
|||
if ((e = xh_get_int(&pic->macros, rename)) == NULL) {
|
||||
return NULL;
|
||||
}
|
||||
return xh_val(e, struct pic_macro *);
|
||||
return xh_val(e, struct pic_proc *);
|
||||
}
|
||||
|
||||
static pic_sym
|
||||
|
@ -252,13 +246,19 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
|
||||
}
|
||||
|
||||
define_macro(pic, rename, pic_proc_ptr(val), senv);
|
||||
val = pic_apply1(pic, pic_proc_ptr(val), pic_obj_value(senv));
|
||||
|
||||
if (! pic_proc_p(val)) {
|
||||
pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
|
||||
}
|
||||
|
||||
define_macro(pic, rename, pic_proc_ptr(val));
|
||||
|
||||
return pic_none_value();
|
||||
}
|
||||
|
||||
static pic_value
|
||||
macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv)
|
||||
macroexpand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_senv *senv)
|
||||
{
|
||||
pic_value v, args;
|
||||
|
||||
|
@ -268,14 +268,10 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct
|
|||
puts("");
|
||||
#endif
|
||||
|
||||
if (mac->senv == NULL) { /* legacy macro */
|
||||
args = pic_cdr(pic, expr);
|
||||
} else {
|
||||
args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv));
|
||||
}
|
||||
args = pic_list2(pic, expr, pic_obj_value(senv));
|
||||
|
||||
pic_try {
|
||||
v = pic_apply(pic, mac->proc, args);
|
||||
v = pic_apply(pic, mac, args);
|
||||
} pic_catch {
|
||||
pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic));
|
||||
}
|
||||
|
@ -298,7 +294,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
}
|
||||
case PIC_TT_PAIR: {
|
||||
pic_value car;
|
||||
struct pic_macro *mac;
|
||||
struct pic_proc *mac;
|
||||
|
||||
if (! pic_list_p(expr)) {
|
||||
pic_errorf(pic, "cannot macroexpand improper list: ~s", expr);
|
||||
|
@ -424,13 +420,33 @@ pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym,
|
|||
}
|
||||
}
|
||||
|
||||
static pic_value
|
||||
defmacro_call(pic_state *pic)
|
||||
{
|
||||
struct pic_proc *self = pic_get_proc(pic);
|
||||
pic_value args, tmp, proc;
|
||||
|
||||
pic_get_args(pic, "oo", &args, &tmp);
|
||||
|
||||
proc = pic_attr_ref(pic, pic_obj_value(self), "@@transformer");
|
||||
|
||||
return pic_apply_trampoline(pic, pic_proc_ptr(proc), pic_cdr(pic, args));
|
||||
}
|
||||
|
||||
void
|
||||
pic_defmacro(pic_state *pic, pic_sym name, pic_sym id, pic_func_t func)
|
||||
{
|
||||
struct pic_proc *proc, *trans;
|
||||
|
||||
trans = pic_make_proc(pic, func, pic_symbol_name(pic, name));
|
||||
|
||||
pic_put_rename(pic, pic->lib->env, name, id);
|
||||
|
||||
proc = pic_make_proc(pic, defmacro_call, "defmacro_call");
|
||||
pic_attr_set(pic, pic_obj_value(proc), "@@transformer", pic_obj_value(trans));
|
||||
|
||||
/* symbol registration */
|
||||
define_macro(pic, id, pic_make_proc(pic, func, pic_symbol_name(pic, name)), NULL);
|
||||
define_macro(pic, id, proc);
|
||||
|
||||
/* auto export! */
|
||||
pic_export(pic, name);
|
||||
|
|
|
@ -47,19 +47,23 @@
|
|||
(make-syntactic-closure env '() form))
|
||||
|
||||
(define-syntax capture-syntactic-environment
|
||||
(lambda (form use-env mac-env)
|
||||
(list (cadr form) (list (make-identifier 'quote mac-env) mac-env))))
|
||||
(lambda (mac-env)
|
||||
(lambda (form use-env)
|
||||
(list (cadr form) (list (make-identifier 'quote mac-env) mac-env)))))
|
||||
|
||||
(define (sc-macro-transformer f)
|
||||
(lambda (expr use-env mac-env)
|
||||
(make-syntactic-closure mac-env '() (f expr use-env))))
|
||||
(lambda (mac-env)
|
||||
(lambda (expr use-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))))
|
||||
(lambda (mac-env)
|
||||
(lambda (expr use-env)
|
||||
(make-syntactic-closure use-env '() (f expr mac-env)))))
|
||||
|
||||
(define (er-macro-transformer f)
|
||||
(lambda (expr use-env mac-env)
|
||||
(lambda (mac-env)
|
||||
(lambda (expr use-env)
|
||||
|
||||
(define rename
|
||||
(memoize
|
||||
|
@ -73,10 +77,11 @@
|
|||
#f
|
||||
(identifier=? use-env x use-env y))))
|
||||
|
||||
(f expr rename compare)))
|
||||
(f expr rename compare))))
|
||||
|
||||
(define (ir-macro-transformer f)
|
||||
(lambda (expr use-env mac-env)
|
||||
(lambda (mac-env)
|
||||
(lambda (expr use-env)
|
||||
|
||||
(define icache* (make-dictionary))
|
||||
|
||||
|
@ -105,7 +110,7 @@
|
|||
(if exists
|
||||
value
|
||||
(rename sym)))))
|
||||
(f (walk inject expr) inject compare))))
|
||||
(f (walk inject expr) inject compare)))))
|
||||
|
||||
;; (define (strip-syntax form)
|
||||
;; (walk ungensym form))
|
||||
|
|
|
@ -7,7 +7,8 @@
|
|||
(lambda (expr r c)
|
||||
(list (r 'define-syntax) (cadr expr)
|
||||
(list (r 'lambda) '_
|
||||
(list (r 'error) "invalid use of auxiliary syntax"))))))
|
||||
(list (r 'lambda) '_
|
||||
(list (r 'error) "invalid use of auxiliary syntax")))))))
|
||||
|
||||
(define-auxiliary-syntax _)
|
||||
(define-auxiliary-syntax ...)
|
||||
|
|
Loading…
Reference in New Issue