Merge branch 'master' into refactor-contrib
This commit is contained in:
commit
26b721cc6a
|
@ -50,6 +50,7 @@ Utility functions and syntaces for macro definition.
|
|||
- define-macro
|
||||
- gensym
|
||||
- macroexpand
|
||||
- macroexpand-1
|
||||
|
||||
Old-fashioned macro.
|
||||
|
||||
|
|
|
@ -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 */
|
||||
|
|
|
@ -12,7 +12,7 @@ extern "C" {
|
|||
struct pic_lib {
|
||||
PIC_OBJECT_HEADER
|
||||
pic_value name;
|
||||
struct pic_senv *senv;
|
||||
struct pic_senv *env;
|
||||
xhash exports;
|
||||
};
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -51,7 +51,7 @@ static void pop_scope(analyze_state *);
|
|||
#define register_renamed_symbol(pic, state, slot, lib, id) do { \
|
||||
pic_sym sym, gsym; \
|
||||
sym = pic_intern_cstr(pic, id); \
|
||||
if (! pic_find_rename(pic, lib->senv, sym, &gsym)) { \
|
||||
if (! pic_find_rename(pic, lib->env, sym, &gsym)) { \
|
||||
pic_error(pic, "internal error! native VM procedure not found"); \
|
||||
} \
|
||||
state->slot = gsym; \
|
||||
|
|
2
src/gc.c
2
src/gc.c
|
@ -463,7 +463,7 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
|
|||
case PIC_TT_LIB: {
|
||||
struct pic_lib *lib = (struct pic_lib *)obj;
|
||||
gc_mark(pic, lib->name);
|
||||
gc_mark_object(pic, (struct pic_object *)lib->senv);
|
||||
gc_mark_object(pic, (struct pic_object *)lib->env);
|
||||
break;
|
||||
}
|
||||
case PIC_TT_VAR: {
|
||||
|
|
17
src/init.c
17
src/init.c
|
@ -62,15 +62,14 @@ pic_init_core(pic_state *pic)
|
|||
pic_deflibrary ("(scheme base)") {
|
||||
|
||||
/* load core syntaces */
|
||||
pic->lib->senv = pic_null_syntactic_environment(pic);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE, pic->rDEFINE);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sSETBANG, pic->rSETBANG);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sQUOTE, pic->rQUOTE);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLAMBDA, pic->rLAMBDA);
|
||||
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->lib->env = pic_null_syntactic_environment(pic);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
|
||||
|
||||
pic_init_bool(pic); DONE;
|
||||
pic_init_pair(pic); DONE;
|
||||
|
|
|
@ -27,7 +27,7 @@ pic_make_library(pic_state *pic, pic_value name)
|
|||
senv = pic_null_syntactic_environment(pic);
|
||||
|
||||
lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB);
|
||||
lib->senv = senv;
|
||||
lib->env = senv;
|
||||
lib->name = name;
|
||||
xh_init_int(&lib->exports, sizeof(pic_sym));
|
||||
|
||||
|
@ -78,7 +78,7 @@ pic_import(pic_state *pic, pic_value spec)
|
|||
printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it.e, pic_sym)), pic_symbol_name(pic, xh_val(it.e, pic_sym)));
|
||||
#endif
|
||||
|
||||
pic_put_rename(pic, pic->lib->senv, xh_key(it.e, pic_sym), xh_val(it.e, pic_sym));
|
||||
pic_put_rename(pic, pic->lib->env, xh_key(it.e, pic_sym), xh_val(it.e, pic_sym));
|
||||
}
|
||||
}
|
||||
|
||||
|
@ -87,7 +87,7 @@ pic_export(pic_state *pic, pic_sym sym)
|
|||
{
|
||||
pic_sym rename;
|
||||
|
||||
if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) {
|
||||
if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
|
||||
pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym));
|
||||
}
|
||||
|
||||
|
@ -103,7 +103,7 @@ pic_export_as(pic_state *pic, pic_sym sym, pic_sym as)
|
|||
{
|
||||
pic_sym rename;
|
||||
|
||||
if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) {
|
||||
if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
|
||||
pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym));
|
||||
}
|
||||
|
||||
|
|
118
src/macro.c
118
src/macro.c
|
@ -10,6 +10,7 @@
|
|||
#include "picrin/lib.h"
|
||||
#include "picrin/error.h"
|
||||
#include "picrin/dict.h"
|
||||
#include "picrin/cont.h"
|
||||
|
||||
pic_sym
|
||||
pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym)
|
||||
|
@ -215,17 +216,11 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
|
||||
pic_value v = pic_car(pic, a);
|
||||
|
||||
if (! pic_sym_p(v)) {
|
||||
v = macroexpand(pic, v, senv);
|
||||
}
|
||||
if (! pic_sym_p(v)) {
|
||||
pic_error(pic, "syntax error");
|
||||
}
|
||||
pic_add_rename(pic, in, pic_sym(v));
|
||||
}
|
||||
if (! pic_sym_p(a)) {
|
||||
a = macroexpand(pic, a, senv);
|
||||
}
|
||||
if (pic_sym_p(a)) {
|
||||
pic_add_rename(pic, in, pic_sym(a));
|
||||
}
|
||||
|
@ -258,9 +253,6 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
}
|
||||
var = formal;
|
||||
}
|
||||
if (! pic_sym_p(var)) {
|
||||
var = macroexpand(pic, var, senv);
|
||||
}
|
||||
if (! pic_sym_p(var)) {
|
||||
pic_error(pic, "binding to non-symbol object");
|
||||
}
|
||||
|
@ -288,9 +280,6 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
}
|
||||
|
||||
var = pic_cadr(pic, expr);
|
||||
if (! pic_sym_p(var)) {
|
||||
var = macroexpand(pic, var, senv);
|
||||
}
|
||||
if (! pic_sym_p(var)) {
|
||||
pic_error(pic, "binding to non-symbol object");
|
||||
}
|
||||
|
@ -316,44 +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)) {
|
||||
var = macroexpand(pic, var, senv);
|
||||
}
|
||||
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)
|
||||
{
|
||||
|
@ -424,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);
|
||||
}
|
||||
|
@ -497,7 +445,7 @@ pic_macroexpand(pic_state *pic, pic_value expr)
|
|||
puts("");
|
||||
#endif
|
||||
|
||||
v = macroexpand(pic, expr, pic->lib->senv);
|
||||
v = macroexpand(pic, expr, pic->lib->env);
|
||||
|
||||
#if DEBUG
|
||||
puts("after expand:");
|
||||
|
@ -508,6 +456,47 @@ pic_macroexpand(pic_state *pic, pic_value expr)
|
|||
return v;
|
||||
}
|
||||
|
||||
static pic_value
|
||||
macroexpand_one(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
||||
{
|
||||
struct pic_macro *mac;
|
||||
pic_value v, args;
|
||||
|
||||
if (pic_sym_p(expr)) {
|
||||
pic_sym sym;
|
||||
|
||||
sym = pic_sym(expr);
|
||||
|
||||
if (pic_interned_p(pic, sym)) {
|
||||
return pic_sym_value(make_identifier(pic, pic_sym(expr), senv));
|
||||
}
|
||||
}
|
||||
if (pic_pair_p(expr) && pic_sym_p(pic_car(pic, expr))) {
|
||||
pic_sym sym;
|
||||
|
||||
sym = make_identifier(pic, pic_sym(pic_car(pic, expr)), senv);
|
||||
|
||||
if ((mac = find_macro(pic, sym)) != NULL) {
|
||||
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 while application: %s", pic_errmsg(pic));
|
||||
}
|
||||
|
||||
return v;
|
||||
}
|
||||
}
|
||||
|
||||
return pic_undef_value(); /* no expansion occurred */
|
||||
}
|
||||
|
||||
struct pic_senv *
|
||||
pic_senv_new(pic_state *pic, struct pic_senv *up)
|
||||
{
|
||||
|
@ -539,7 +528,7 @@ pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym,
|
|||
{
|
||||
pic_put_rename(pic, senv, sym, rsym);
|
||||
|
||||
if (pic->lib && pic->lib->senv == senv) {
|
||||
if (pic->lib && pic->lib->env == senv) {
|
||||
pic_export(pic, sym);
|
||||
}
|
||||
}
|
||||
|
@ -551,7 +540,7 @@ pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
|
|||
|
||||
/* symbol registration */
|
||||
sym = pic_intern_cstr(pic, name);
|
||||
rename = pic_add_rename(pic, pic->lib->senv, sym);
|
||||
rename = pic_add_rename(pic, pic->lib->env, sym);
|
||||
define_macro(pic, rename, macro, NULL);
|
||||
|
||||
/* auto export! */
|
||||
|
@ -595,6 +584,22 @@ pic_macro_macroexpand(pic_state *pic)
|
|||
return pic_macroexpand(pic, expr);
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_macro_macroexpand_1(pic_state *pic)
|
||||
{
|
||||
pic_value expr, val;
|
||||
|
||||
pic_get_args(pic, "o", &expr);
|
||||
|
||||
val = macroexpand_one(pic, expr, pic->lib->env);
|
||||
if (pic_undef_p(val)) {
|
||||
return pic_values2(pic, expr, pic_false_value());
|
||||
}
|
||||
else {
|
||||
return pic_values2(pic, val, pic_true_value());
|
||||
}
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_macro_identifier_p(pic_state *pic)
|
||||
{
|
||||
|
@ -645,6 +650,7 @@ pic_init_macro(pic_state *pic)
|
|||
pic_deflibrary ("(picrin macro)") {
|
||||
pic_defun(pic, "gensym", pic_macro_gensym);
|
||||
pic_defun(pic, "macroexpand", pic_macro_macroexpand);
|
||||
pic_defun(pic, "macroexpand-1", pic_macro_macroexpand_1);
|
||||
pic_defun(pic, "identifier?", pic_macro_identifier_p);
|
||||
pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p);
|
||||
pic_defun(pic, "make-identifier", pic_macro_make_identifier);
|
||||
|
|
|
@ -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");
|
||||
|
|
4
src/vm.c
4
src/vm.c
|
@ -376,7 +376,7 @@ global_ref(pic_state *pic, const char *name)
|
|||
pic_sym sym, rename;
|
||||
|
||||
sym = pic_intern_cstr(pic, name);
|
||||
if (! pic_find_rename(pic, pic->lib->senv, sym, &rename)) {
|
||||
if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) {
|
||||
return SIZE_MAX;
|
||||
}
|
||||
if (! (e = xh_get_int(&pic->global_tbl, rename))) {
|
||||
|
@ -398,7 +398,7 @@ global_def(pic_state *pic, const char *name)
|
|||
}
|
||||
|
||||
/* register to the senv */
|
||||
rename = pic_add_rename(pic, pic->lib->senv, sym);
|
||||
rename = pic_add_rename(pic, pic->lib->env, sym);
|
||||
|
||||
/* register to the global table */
|
||||
gidx = pic->glen++;
|
||||
|
|
Loading…
Reference in New Issue