Skip to content
This repository has been archived by the owner on Mar 26, 2024. It is now read-only.

Commit

Permalink
remove 'struct pic_macro'. define-syntax spec is changed.
Browse files Browse the repository at this point in the history
  • Loading branch information
@nyuichi
nyuichi committed Jan 18, 2015
1 parent 592af90 commit a3db19c
Show file tree
Hide file tree
Showing 7 changed files with 120 additions and 120 deletions.
56 changes: 30 additions & 26 deletions extlib/benz/boot.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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 =>)
Expand Down Expand Up @@ -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"
Expand All @@ -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"
Expand Down
14 changes: 0 additions & 14 deletions extlib/benz/gc.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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;

Expand Down Expand Up @@ -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);
Expand Down
9 changes: 0 additions & 9 deletions extlib/benz/include/picrin/macro.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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))

Expand Down
3 changes: 0 additions & 3 deletions extlib/benz/include/picrin/value.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down Expand Up @@ -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:
Expand Down
54 changes: 35 additions & 19 deletions extlib/benz/macro.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -47,26 +47,20 @@ 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;

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
Expand Down Expand Up @@ -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;

Expand All @@ -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));
}
Expand All @@ -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);
Expand Down Expand Up @@ -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);
Expand Down
101 changes: 53 additions & 48 deletions piclib/picrin/macro.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)

(define icache* (make-dictionary))

(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 (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))))
(lambda (mac-env)
(lambda (expr use-env)

(define icache* (make-dictionary))

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

;; (define (strip-syntax form)
;; (walk ungensym form))
Expand Down
3 changes: 2 additions & 1 deletion piclib/picrin/syntax-rules.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 ...)
Expand Down

0 comments on commit a3db19c

Please sign in to comment.