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)))))) val))))))
(define (er-macro-transformer f) (define (er-macro-transformer f)
(lambda (expr use-env mac-env) (lambda (mac-env)
(lambda (expr use-env)
(define rename (define rename
(memoize (memoize
(lambda (sym) (lambda (sym)
(make-identifier sym mac-env)))) (make-identifier sym mac-env))))
(define (compare x y) (define (compare x y)
(if (not (symbol? x)) (if (not (symbol? x))
#f #f
(if (not (symbol? y)) (if (not (symbol? y))
#f #f
(identifier=? use-env x use-env y)))) (identifier=? use-env x use-env y))))
(f expr rename compare))) (f expr rename compare))))
(define-syntax syntax-error (define-syntax syntax-error
(er-macro-transformer (er-macro-transformer
@ -50,7 +51,8 @@ my $src = <<'EOL';
(lambda (expr r c) (lambda (expr r c)
(list (r 'define-syntax) (cadr expr) (list (r 'define-syntax) (cadr expr)
(list (r 'lambda) '_ (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 else)
(define-auxiliary-syntax =>) (define-auxiliary-syntax =>)
@ -422,21 +424,22 @@ const char pic_boot[] =
" val))))))\n" " val))))))\n"
"\n" "\n"
" (define (er-macro-transformer f)\n" " (define (er-macro-transformer f)\n"
" (lambda (expr use-env mac-env)\n" " (lambda (mac-env)\n"
" (lambda (expr use-env)\n"
"\n" "\n"
" (define rename\n" " (define rename\n"
" (memoize\n" " (memoize\n"
" (lambda (sym)\n" " (lambda (sym)\n"
" (make-identifier sym mac-env))))\n" " (make-identifier sym mac-env))))\n"
"\n" "\n"
" (define (compare x y)\n" " (define (compare x y)\n"
" (if (not (symbol? x))\n" " (if (not (symbol? x))\n"
" #f\n" " #f\n"
" (if (not (symbol? y))\n" " (if (not (symbol? y))\n"
" #f\n" " #f\n"
" (identifier=? use-env x use-env y))))\n" " (identifier=? use-env x use-env y))))\n"
"\n" "\n"
" (f expr rename compare)))\n" " (f expr rename compare))))\n"
"\n" "\n"
" (define-syntax syntax-error\n" " (define-syntax syntax-error\n"
" (er-macro-transformer\n" " (er-macro-transformer\n"
@ -448,7 +451,8 @@ const char pic_boot[] =
" (lambda (expr r c)\n" " (lambda (expr r c)\n"
" (list (r 'define-syntax) (cadr expr)\n" " (list (r 'define-syntax) (cadr expr)\n"
" (list (r 'lambda) '_\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" "\n"
" (define-auxiliary-syntax else)\n" " (define-auxiliary-syntax else)\n"
" (define-auxiliary-syntax =>)\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: { case PIC_TT_BLOB: {
break; 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: { case PIC_TT_SENV: {
struct pic_senv *senv = (struct pic_senv *)obj; 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); xh_destroy(&senv->map);
break; break;
} }
case PIC_TT_MACRO: {
break;
}
case PIC_TT_LIB: { case PIC_TT_LIB: {
struct pic_lib *lib = (struct pic_lib *)obj; struct pic_lib *lib = (struct pic_lib *)obj;
xh_destroy(&lib->exports); 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_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_p(v) (pic_type(v) == PIC_TT_SENV)
#define pic_senv_ptr(v) ((struct pic_senv *)pic_ptr(v)) #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_ERROR,
PIC_TT_ENV, PIC_TT_ENV,
PIC_TT_SENV, PIC_TT_SENV,
PIC_TT_MACRO,
PIC_TT_LIB, PIC_TT_LIB,
PIC_TT_IREP, PIC_TT_IREP,
PIC_TT_DATA, PIC_TT_DATA,
@ -266,8 +265,6 @@ pic_type_repr(enum pic_tt tt)
return "proc"; return "proc";
case PIC_TT_SENV: case PIC_TT_SENV:
return "senv"; return "senv";
case PIC_TT_MACRO:
return "macro";
case PIC_TT_LIB: case PIC_TT_LIB:
return "lib"; return "lib";
case PIC_TT_IREP: 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 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); xh_put_int(&pic->macros, rename, &mac);
} }
static struct pic_macro * static struct pic_proc *
find_macro(pic_state *pic, pic_sym rename) find_macro(pic_state *pic, pic_sym rename)
{ {
xh_entry *e; xh_entry *e;
@ -66,7 +60,7 @@ find_macro(pic_state *pic, pic_sym rename)
if ((e = xh_get_int(&pic->macros, rename)) == NULL) { if ((e = xh_get_int(&pic->macros, rename)) == NULL) {
return NULL; return NULL;
} }
return xh_val(e, struct pic_macro *); return xh_val(e, struct pic_proc *);
} }
static pic_sym 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); 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(); return pic_none_value();
} }
static pic_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; pic_value v, args;
@ -268,14 +268,10 @@ macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct
puts(""); puts("");
#endif #endif
if (mac->senv == NULL) { /* legacy macro */ args = pic_list2(pic, expr, pic_obj_value(senv));
args = pic_cdr(pic, expr);
} else {
args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv));
}
pic_try { pic_try {
v = pic_apply(pic, mac->proc, args); v = pic_apply(pic, mac, args);
} pic_catch { } pic_catch {
pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic)); 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: { case PIC_TT_PAIR: {
pic_value car; pic_value car;
struct pic_macro *mac; struct pic_proc *mac;
if (! pic_list_p(expr)) { if (! pic_list_p(expr)) {
pic_errorf(pic, "cannot macroexpand improper list: ~s", 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 void
pic_defmacro(pic_state *pic, pic_sym name, pic_sym id, pic_func_t func) 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); 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 */ /* symbol registration */
define_macro(pic, id, pic_make_proc(pic, func, pic_symbol_name(pic, name)), NULL); define_macro(pic, id, proc);
/* auto export! */ /* auto export! */
pic_export(pic, name); pic_export(pic, name);

91
piclib/picrin/macro.scm
View File

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

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

@ -7,7 +7,8 @@
(lambda (expr r c) (lambda (expr r c)
(list (r 'define-syntax) (cadr expr) (list (r 'define-syntax) (cadr expr)
(list (r 'lambda) '_ (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 _)
(define-auxiliary-syntax ...) (define-auxiliary-syntax ...)