conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

remove 'struct pic_macro'. define-syntax spec is changed.

This commit is contained in:
Yuichi Nishiwaki 2015-01-18 15:48:05 +09:00
parent 592af901e2
commit a3db19c1bf
7 changed files with 115 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
extlib/benz/boot.c
View File

@ -24,21 +24,22 @@ 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
(lambda (sym)
(make-identifier sym mac-env))))
(define rename
(memoize
(lambda (sym)
(make-identifier sym mac-env))))
(define (compare x y)
(if (not (symbol? x))
#f
(if (not (symbol? y))
#f
(identifier=? use-env x use-env y))))
(define (compare x y)
(if (not (symbol? x))
#f
(if (not (symbol? y))
#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,21 +424,22 @@ 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"
" (lambda (sym)\n"
" (make-identifier sym mac-env))))\n"
" (define rename\n"
" (memoize\n"
" (lambda (sym)\n"
" (make-identifier sym mac-env))))\n"
"\n"
" (define (compare x y)\n"
" (if (not (symbol? x))\n"
" #f\n"
" (if (not (symbol? y))\n"
" #f\n"
" (identifier=? use-env x use-env y))))\n"
" (define (compare x y)\n"
" (if (not (symbol? x))\n"
" #f\n"
" (if (not (symbol? y))\n"
" #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"

14
extlib/benz/gc.c
View File

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

9
extlib/benz/include/picrin/macro.h
View File

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

3
extlib/benz/include/picrin/value.h
View File

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

54
extlib/benz/macro.c
View File

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

91
piclib/picrin/macro.scm
View File

@ -47,65 +47,70 @@
(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
(lambda (sym)
(make-identifier sym mac-env))))
(define rename
(memoize
(lambda (sym)
(make-identifier sym mac-env))))
(define (compare x y)
(if (not (symbol? x))
#f
(if (not (symbol? y))
#f
(identifier=? use-env x use-env y))))
(define (compare x y)
(if (not (symbol? x))
#f
(if (not (symbol? y))
#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))
(define icache* (make-dictionary))
(define inject
(memoize
(lambda (sym)
(define id (make-identifier sym use-env))
(dictionary-set! icache* id sym)
id)))
(define inject
(memoize
(lambda (sym)
(define id (make-identifier sym use-env))
(dictionary-set! icache* id sym)
id)))
(define rename
(memoize
(lambda (sym)
(make-identifier sym mac-env))))
(define rename
(memoize
(lambda (sym)
(make-identifier sym mac-env))))
(define (compare x y)
(if (not (symbol? x))
#f
(if (not (symbol? y))
#f
(identifier=? mac-env x mac-env y))))
(define (compare x y)
(if (not (symbol? x))
#f
(if (not (symbol? y))
#f
(identifier=? mac-env x mac-env y))))
(walk (lambda (sym)
(call-with-values (lambda () (dictionary-ref icache* sym))
(lambda (value exists)
(if exists
value
(rename sym)))))
(f (walk inject expr) inject compare))))
(walk (lambda (sym)
(call-with-values (lambda () (dictionary-ref icache* sym))
(lambda (value exists)
(if exists
value
(rename sym)))))
(f (walk inject expr) inject compare)))))
;; (define (strip-syntax form)
;; (walk ungensym form))

3
piclib/picrin/syntax-rules.scm
View File

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