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

support let-syntax

This commit is contained in:
Yuichi Nishiwaki 2014-07-13 22:36:30 +09:00
parent 730cfc8601
commit 6c45bb3c5d
4 changed files with 170 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
include/picrin.h
View File

@ -81,6 +81,7 @@ typedef struct {
pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG; pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG;
pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING; pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING;
pic_sym sDEFINE_SYNTAX, sDEFINE_MACRO; pic_sym sDEFINE_SYNTAX, sDEFINE_MACRO;
pic_sym sLET_SYNTAX, sLETREC_SYNTAX;
pic_sym sDEFINE_LIBRARY, sIMPORT, sEXPORT; pic_sym sDEFINE_LIBRARY, sIMPORT, sEXPORT;
pic_sym sCONS, sCAR, sCDR, sNILP; pic_sym sCONS, sCAR, sCDR, sNILP;
pic_sym sADD, sSUB, sMUL, sDIV, sMINUS; pic_sym sADD, sSUB, sMUL, sDIV, sMINUS;

2
src/init.c
View File

@ -75,6 +75,8 @@ pic_init_core(pic_state *pic)
pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF); pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF);
pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN); pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN);
pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX); pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX);
pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX);
pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLETREC_SYNTAX);
pic_init_bool(pic); DONE; pic_init_bool(pic); DONE;
pic_init_pair(pic); DONE; pic_init_pair(pic); DONE;

284
src/macro.c
View File

@ -184,125 +184,6 @@ macroexpand_deflibrary(pic_state *pic, pic_value expr)
return pic_none_value(); return pic_none_value();
} }
static pic_value
macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
{
pic_value var, val;
pic_sym sym, rename;
if (pic_length(pic, expr) != 3) {
pic_error(pic, "syntax error");
}
var = pic_cadr(pic, expr);
if (! pic_sym_p(var)) {
var = macroexpand(pic, var, senv, cxt);
}
if (! pic_sym_p(var)) {
pic_error(pic, "binding to non-symbol object");
}
sym = pic_sym(var);
if (! pic_find_rename(pic, senv, sym, &rename)) {
rename = pic_add_rename(pic, senv, sym);
}
val = pic_cadr(pic, pic_cdr(pic, expr));
pic_try {
val = pic_eval(pic, val);
} pic_catch {
pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
}
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), senv);
return pic_none_value();
}
static pic_value
macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv)
{
pic_value var, val;
pic_sym sym, rename;
if (pic_length(pic, expr) < 2) {
pic_error(pic, "syntax error");
}
var = pic_car(pic, pic_cdr(pic, expr));
if (pic_pair_p(var)) {
/* FIXME: unhygienic */
val = pic_cons(pic, pic_sym_value(pic->sLAMBDA),
pic_cons(pic, pic_cdr(pic, var),
pic_cdr(pic, pic_cdr(pic, expr))));
var = pic_car(pic, var);
}
else {
if (pic_length(pic, expr) != 3) {
pic_error(pic, "syntax_error");
}
val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, expr)));
}
if (! pic_sym_p(var)) {
pic_error(pic, "syntax error");
}
sym = pic_sym(var);
if (! pic_find_rename(pic, senv, sym, &rename)) {
rename = pic_add_rename(pic, senv, sym);
}
pic_try {
val = pic_eval(pic, val);
} pic_catch {
pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
}
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), NULL);
return pic_none_value();
}
static pic_value
macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
{
pic_value v, args;
#if DEBUG
puts("before expand-1:");
pic_debug(pic, expr);
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));
}
pic_try {
v = pic_apply(pic, mac->proc, args);
} pic_catch {
pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
}
#if DEBUG
puts("after expand-1:");
pic_debug(pic, v);
puts("");
#endif
return macroexpand(pic, v, senv, cxt);
}
static pic_value static pic_value
macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv, struct pic_dict *cxt) macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv, struct pic_dict *cxt)
{ {
@ -402,6 +283,165 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct
return pic_list3(pic, pic_sym_value(pic->sDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val); return pic_list3(pic, pic_sym_value(pic->sDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val);
} }
static pic_value
macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
{
pic_value var, val;
pic_sym sym, rename;
if (pic_length(pic, expr) != 3) {
pic_error(pic, "syntax error");
}
var = pic_cadr(pic, expr);
if (! pic_sym_p(var)) {
var = macroexpand(pic, var, senv, cxt);
}
if (! pic_sym_p(var)) {
pic_error(pic, "binding to non-symbol object");
}
sym = pic_sym(var);
if (! pic_find_rename(pic, senv, sym, &rename)) {
rename = pic_add_rename(pic, senv, sym);
}
val = pic_cadr(pic, pic_cdr(pic, expr));
pic_try {
val = pic_eval(pic, val);
} pic_catch {
pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
}
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), senv);
return pic_none_value();
}
static pic_value
macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_senv *senv)
{
pic_value var, val;
pic_sym sym, rename;
if (pic_length(pic, expr) < 2) {
pic_error(pic, "syntax error");
}
var = pic_car(pic, pic_cdr(pic, expr));
if (pic_pair_p(var)) {
/* FIXME: unhygienic */
val = pic_cons(pic, pic_sym_value(pic->sLAMBDA),
pic_cons(pic, pic_cdr(pic, var),
pic_cdr(pic, pic_cdr(pic, expr))));
var = pic_car(pic, var);
}
else {
if (pic_length(pic, expr) != 3) {
pic_error(pic, "syntax_error");
}
val = pic_car(pic, pic_cdr(pic, pic_cdr(pic, expr)));
}
if (! pic_sym_p(var)) {
pic_error(pic, "syntax error");
}
sym = pic_sym(var);
if (! pic_find_rename(pic, senv, sym, &rename)) {
rename = pic_add_rename(pic, senv, sym);
}
pic_try {
val = pic_eval(pic, val);
} pic_catch {
pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
}
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), NULL);
return pic_none_value();
}
static pic_value
macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
{
struct pic_senv *in;
pic_value formal, v, var, val;
pic_sym sym, rename;
in = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
in->up = senv;
xh_init_int(&in->renames, sizeof(pic_sym));
if (pic_length(pic, expr) < 2) {
pic_error(pic, "syntax error");
}
formal = pic_cadr(pic, expr);
if (! pic_list_p(formal)) {
pic_error(pic, "syntax error");
}
pic_for_each (v, formal) {
var = pic_car(pic, v);
if (! pic_sym_p(var)) {
var = macroexpand(pic, var, senv, cxt);
}
if (! pic_sym_p(var)) {
pic_error(pic, "binding to non-symbol object");
}
sym = pic_sym(var);
if (! pic_find_rename(pic, in, sym, &rename)) {
rename = pic_add_rename(pic, in, sym);
}
val = pic_eval(pic, pic_cadr(pic, v));
if (! pic_proc_p(val)) {
pic_errorf(pic, "macro definition \"~s\" evaluated to non-procedure object", var);
}
define_macro(pic, rename, pic_proc_ptr(val), senv);
}
return pic_cons(pic, pic_sym_value(pic->sBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in, cxt));
}
static pic_value
macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
{
pic_value v, args;
#if DEBUG
puts("before expand-1:");
pic_debug(pic, expr);
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));
}
pic_try {
v = pic_apply(pic, mac->proc, args);
} pic_catch {
pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
}
#if DEBUG
puts("after expand-1:");
pic_debug(pic, v);
puts("");
#endif
return macroexpand(pic, v, senv, cxt);
}
static pic_value static pic_value
macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt) macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct pic_dict *cxt)
{ {
@ -445,6 +485,12 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p
else if (tag == pic->sDEFINE_MACRO) { else if (tag == pic->sDEFINE_MACRO) {
return macroexpand_defmacro(pic, expr, senv); return macroexpand_defmacro(pic, expr, senv);
} }
else if (tag == pic->sLET_SYNTAX) {
return macroexpand_let_syntax(pic, expr, senv, cxt);
}
/* else if (tag == pic->sLETREC_SYNTAX) { */
/* return macroexpand_letrec_syntax(pic, expr, senv, cxt); */
/* } */
else if (tag == pic->sLAMBDA) { else if (tag == pic->sLAMBDA) {
return macroexpand_lambda(pic, expr, senv, cxt); return macroexpand_lambda(pic, expr, senv, cxt);
} }

2
src/state.c
View File

@ -96,6 +96,8 @@ pic_open(int argc, char *argv[], char **envp)
register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing"); register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing");
register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax"); register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax");
register_core_symbol(pic, sDEFINE_MACRO, "define-macro"); register_core_symbol(pic, sDEFINE_MACRO, "define-macro");
register_core_symbol(pic, sLET_SYNTAX, "let-syntax");
register_core_symbol(pic, sLETREC_SYNTAX, "letrec-syntax");
register_core_symbol(pic, sDEFINE_LIBRARY, "define-library"); register_core_symbol(pic, sDEFINE_LIBRARY, "define-library");
register_core_symbol(pic, sIMPORT, "import"); register_core_symbol(pic, sIMPORT, "import");
register_core_symbol(pic, sEXPORT, "export"); register_core_symbol(pic, sEXPORT, "export");