introduce legacy macros

This commit is contained in:
Yuichi Nishiwaki 2013-10-30 16:37:43 +09:00
parent 979a1dd80b
commit b7e55b043f
5 changed files with 139 additions and 1 deletions

View File

@ -13,6 +13,7 @@
#define PIC_STACK_SIZE 1024
#define PIC_IREP_SIZE 256
#define PIC_GLOBALS_SIZE 1024
#define PIC_MACROS_SIZE 1024
#define PIC_SYM_POOL_SIZE 128
#define PIC_POOL_SIZE 1024

View File

@ -30,6 +30,7 @@ typedef struct {
pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG;
pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING;
pic_sym sDEFINE_SYNTAX, sDEFINE_MACRO;
pic_sym sCONS, sCAR, sCDR, sNILP;
pic_sym sADD, sSUB, sMUL, sDIV;
pic_sym sEQ, sLT, sLE, sGT, sGE;
@ -38,9 +39,12 @@ typedef struct {
const char **sym_pool;
size_t slen, scapa;
/* positive for variables, negative for macros (bitnot) */
struct xhash *global_tbl;
pic_value *globals;
size_t glen, gcapa;
struct pic_proc **macros;
size_t mlen, mcapa;
struct pic_irep **irep;
size_t ilen, icapa;
@ -92,6 +96,7 @@ bool pic_parse_cstr(pic_state *, const char *, pic_value *);
pic_value pic_apply(pic_state *pic, struct pic_proc *, pic_value);
pic_value pic_apply_argv(pic_state *pic, struct pic_proc *, size_t, ...);
struct pic_proc *pic_codegen(pic_state *, pic_value);
pic_value pic_expand(pic_state *, pic_value);
void pic_abort(pic_state *, const char *);
void pic_raise(pic_state *, pic_value);

View File

@ -131,7 +131,7 @@ scope_lookup(codegen_state *state, const char *key, int *depth, int *idx)
enter:
e = xh_get(scope->local_tbl, key);
if (e) {
if (e && e->val >= 0) {
if (scope->up == NULL) { /* global */
*depth = -1;
}

127
src/expand.c Normal file
View File

@ -0,0 +1,127 @@
#include <stdio.h>
#include <assert.h>
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/proc.h"
#include "xhash/xhash.h"
#define FALLTHROUGH ((void)0)
struct syntactic_env {
struct syntactic_env *up;
struct xhash *tbl;
};
static void
define_macro(pic_state *pic, const char *name, struct pic_proc *macro)
{
int idx;
idx = pic->mlen++;
pic->macros[idx] = macro;
xh_put(pic->global_tbl, name, ~idx);
}
static struct pic_proc *
lookup_macro(pic_state *pic, struct syntactic_env *env, const char *name)
{
struct xh_entry *e;
e = xh_get(env->tbl, name);
if (! e)
return NULL;
if (e->val >= 0)
return NULL;
return pic->macros[~e->val];
}
pic_value
expand(pic_state *pic, pic_value obj, struct syntactic_env *env)
{
int ai = pic_gc_arena_preserve(pic);
switch (pic_type(obj)) {
case PIC_TT_SYMBOL: {
return obj;
}
case PIC_TT_PAIR: {
pic_value v;
if (! pic_list_p(pic, obj))
return obj;
if (pic_symbol_p(pic_car(pic, obj))) {
struct pic_proc *macro;
pic_sym sym;
sym = pic_sym(pic_car(pic, obj));
if (sym == pic->sDEFINE_MACRO) {
v = pic_apply(pic, pic_codegen(pic, pic_car(pic, pic_cdr(pic, pic_cdr(pic, obj)))), pic_nil_value());
assert(pic_proc_p(v));
define_macro(pic, pic_symbol_name(pic, pic_sym(pic_car(pic, pic_cdr(pic, obj)))), pic_proc_ptr(v));
return pic_false_value();
}
macro = lookup_macro(pic, env, pic_symbol_name(pic, sym));
if (macro) {
v = pic_apply(pic, macro, pic_cdr(pic, obj));
if (pic->errmsg) {
printf("macroexpand error: %s\n", pic->errmsg);
abort();
}
return v;
}
}
v = pic_cons(pic, pic_car(pic, obj), pic_nil_value());
for (obj = pic_cdr(pic, obj); ! pic_nil_p(obj); obj = pic_cdr(pic, obj)) {
v = pic_cons(pic, expand(pic, pic_car(pic, obj), env), v);
}
v = pic_reverse(pic, v);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, v);
return v;
}
case PIC_TT_NIL:
case PIC_TT_BOOL:
case PIC_TT_FLOAT:
case PIC_TT_INT:
case PIC_TT_EOF:
case PIC_TT_STRING:
case PIC_TT_VECTOR: {
return obj;
}
case PIC_TT_PROC:
case PIC_TT_PORT:
case PIC_TT_ENV:
case PIC_TT_UNDEF:
pic_error(pic, "logic flaw");
abort(); /* unreachable */
}
}
pic_value
pic_expand(pic_state *pic, pic_value obj)
{
struct syntactic_env env;
pic_value v;
int ai = pic_gc_arena_preserve(pic);
env.tbl = pic->global_tbl;
v = expand(pic, obj, &env);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, v);
#if DEBUG
puts("expanded:");
pic_debug(pic, v);
#endif
return v;
}

View File

@ -48,6 +48,9 @@ pic_open(int argc, char *argv[], char **envp)
pic->globals = (pic_value *)malloc(sizeof(pic_value) * PIC_GLOBALS_SIZE);
pic->glen = 0;
pic->gcapa = PIC_GLOBALS_SIZE;
pic->macros = (struct pic_proc **)malloc(sizeof(struct pic_proc *) * PIC_MACROS_SIZE);
pic->mlen = 0;
pic->mcapa = PIC_MACROS_SIZE;
/* pool */
pic->pool = (pic_value *)malloc(sizeof(pic_value) * PIC_POOL_SIZE);
@ -71,6 +74,8 @@ pic_open(int argc, char *argv[], char **envp)
pic->sQUASIQUOTE = pic_intern_cstr(pic, "quasiquote");
pic->sUNQUOTE = pic_intern_cstr(pic, "unquote");
pic->sUNQUOTE_SPLICING = pic_intern_cstr(pic, "unquote-splicing");
pic->sDEFINE_SYNTAX = pic_intern_cstr(pic, "define-syntax");
pic->sDEFINE_MACRO = pic_intern_cstr(pic, "define-macro");
pic->sCONS = pic_intern_cstr(pic, "cons");
pic->sCAR = pic_intern_cstr(pic, "car");
pic->sCDR = pic_intern_cstr(pic, "cdr");