introduce legacy macros
This commit is contained in:
parent
979a1dd80b
commit
b7e55b043f
|
@ -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
|
||||
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
|
|
@ -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;
|
||||
}
|
|
@ -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");
|
||||
|
|
Loading…
Reference in New Issue