rewrite let-syntax in scheme
This commit is contained in:
parent
0d8e50bf58
commit
7a2f8abd9c
|
@ -80,14 +80,14 @@ typedef struct {
|
|||
|
||||
pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG;
|
||||
pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING;
|
||||
pic_sym sDEFINE_SYNTAX, sLET_SYNTAX;
|
||||
pic_sym sDEFINE_SYNTAX;
|
||||
pic_sym sDEFINE_LIBRARY, sIMPORT, sEXPORT;
|
||||
pic_sym sCONS, sCAR, sCDR, sNILP;
|
||||
pic_sym sADD, sSUB, sMUL, sDIV, sMINUS;
|
||||
pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT;
|
||||
|
||||
pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG;
|
||||
pic_sym rDEFINE_SYNTAX, rLET_SYNTAX;
|
||||
pic_sym rDEFINE_SYNTAX;
|
||||
pic_sym rDEFINE_LIBRARY, rIMPORT, rEXPORT;
|
||||
|
||||
xhash syms; /* name to symbol */
|
||||
|
|
|
@ -271,12 +271,17 @@
|
|||
formal)
|
||||
,@body)))))
|
||||
|
||||
(define-syntax let-syntax
|
||||
(er-macro-transformer
|
||||
(lambda (form r c)
|
||||
`(,(r 'letrec-syntax) ,@(cdr form)))))
|
||||
|
||||
(export let let* letrec letrec*
|
||||
quasiquote unquote unquote-splicing
|
||||
and or
|
||||
cond case else =>
|
||||
do when unless
|
||||
letrec-syntax
|
||||
let-syntax letrec-syntax
|
||||
_ ... syntax-error))
|
||||
|
||||
(import (picrin core-syntax))
|
||||
|
@ -286,7 +291,7 @@
|
|||
and or
|
||||
cond case else =>
|
||||
do when unless
|
||||
letrec-syntax
|
||||
let-syntax letrec-syntax
|
||||
_ ... syntax-error)
|
||||
|
||||
;;; multiple value
|
||||
|
|
|
@ -70,7 +70,6 @@ pic_init_core(pic_state *pic)
|
|||
pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF, pic->rIF);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN, pic->rBEGIN);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX, pic->rLET_SYNTAX);
|
||||
|
||||
pic_init_bool(pic); DONE;
|
||||
pic_init_pair(pic); DONE;
|
||||
|
|
38
src/macro.c
38
src/macro.c
|
@ -305,41 +305,6 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
return pic_none_value();
|
||||
}
|
||||
|
||||
static pic_value
|
||||
macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
||||
{
|
||||
struct pic_senv *in;
|
||||
pic_value formal, v, var, val;
|
||||
pic_sym sym, rename;
|
||||
|
||||
in = pic_senv_new(pic, senv);
|
||||
|
||||
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)) {
|
||||
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->rBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv)
|
||||
{
|
||||
|
@ -410,9 +375,6 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
else if (tag == pic->rDEFINE_SYNTAX) {
|
||||
return macroexpand_defsyntax(pic, expr, senv);
|
||||
}
|
||||
else if (tag == pic->rLET_SYNTAX) {
|
||||
return macroexpand_let_syntax(pic, expr, senv);
|
||||
}
|
||||
else if (tag == pic->rLAMBDA) {
|
||||
return macroexpand_lambda(pic, expr, senv);
|
||||
}
|
||||
|
|
|
@ -95,7 +95,6 @@ pic_open(int argc, char *argv[], char **envp)
|
|||
register_core_symbol(pic, sUNQUOTE, "unquote");
|
||||
register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing");
|
||||
register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax");
|
||||
register_core_symbol(pic, sLET_SYNTAX, "let-syntax");
|
||||
register_core_symbol(pic, sDEFINE_LIBRARY, "define-library");
|
||||
register_core_symbol(pic, sIMPORT, "import");
|
||||
register_core_symbol(pic, sEXPORT, "export");
|
||||
|
@ -128,7 +127,6 @@ pic_open(int argc, char *argv[], char **envp)
|
|||
register_renamed_symbol(pic, rSETBANG, "set!");
|
||||
register_renamed_symbol(pic, rQUOTE, "quote");
|
||||
register_renamed_symbol(pic, rDEFINE_SYNTAX, "define-syntax");
|
||||
register_renamed_symbol(pic, rLET_SYNTAX, "let-syntax");
|
||||
register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library");
|
||||
register_renamed_symbol(pic, rIMPORT, "import");
|
||||
register_renamed_symbol(pic, rEXPORT, "export");
|
||||
|
|
Loading…
Reference in New Issue