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

Merge pull request #245 from picrin-scheme/heap-symbol 

Let symbols to be allocated in heap
This commit is contained in:
Yuichi Nishiwaki 2015-01-20 17:42:01 +09:00
parent 9d2ed448fe 1270787344
commit 129bae29f2
25 changed files with 624 additions and 603 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

353
extlib/benz/codegen.c
View File

@ -8,6 +8,8 @@
#include "picrin/proc.h" #include "picrin/proc.h"
#include "picrin/lib.h" #include "picrin/lib.h"
#include "picrin/macro.h" #include "picrin/macro.h"
#include "picrin/dict.h"
#include "picrin/symbol.h"
#if PIC_NONE_IS_FALSE #if PIC_NONE_IS_FALSE
# define OP_PUSHNONE OP_PUSHFALSE # define OP_PUSHNONE OP_PUSHFALSE
@ -34,13 +36,11 @@ typedef struct analyze_scope {
typedef struct analyze_state { typedef struct analyze_state {
pic_state *pic; pic_state *pic;
analyze_scope *scope; analyze_scope *scope;
pic_sym rCONS, rCAR, rCDR, rNILP; pic_sym *rCONS, *rCAR, *rCDR, *rNILP;
pic_sym rSYMBOL_P, rPAIR_P; pic_sym *rSYMBOLP, *rPAIRP;
pic_sym rADD, rSUB, rMUL, rDIV; pic_sym *rADD, *rSUB, *rMUL, *rDIV;
pic_sym rEQ, rLT, rLE, rGT, rGE, rNOT; pic_sym *rEQ, *rLT, *rLE, *rGT, *rGE, *rNOT;
pic_sym rVALUES, rCALL_WITH_VALUES; pic_sym *rVALUES, *rCALL_WITH_VALUES;
pic_sym sCALL, sTAILCALL, sCALL_WITH_VALUES, sTAILCALL_WITH_VALUES;
pic_sym sGREF, sLREF, sCREF, sRETURN;
} analyze_state; } analyze_state;
static bool push_scope(analyze_state *, pic_value); static bool push_scope(analyze_state *, pic_value);
@ -51,7 +51,7 @@ static void pop_scope(analyze_state *);
} while (0) } while (0)
#define register_renamed_symbol(pic, state, slot, lib, id) do { \ #define register_renamed_symbol(pic, state, slot, lib, id) do { \
pic_sym sym, gsym; \ pic_sym *sym, *gsym; \
sym = pic_intern_cstr(pic, id); \ sym = pic_intern_cstr(pic, id); \
if (! pic_find_rename(pic, lib->env, sym, &gsym)) { \ if (! pic_find_rename(pic, lib->env, sym, &gsym)) { \
pic_errorf(pic, "internal error! native VM procedure not found: %s", id); \ pic_errorf(pic, "internal error! native VM procedure not found: %s", id); \
@ -63,7 +63,7 @@ static analyze_state *
new_analyze_state(pic_state *pic) new_analyze_state(pic_state *pic)
{ {
analyze_state *state; analyze_state *state;
xh_entry *it; pic_sym *sym;
state = pic_alloc(pic, sizeof(analyze_state)); state = pic_alloc(pic, sizeof(analyze_state));
state->pic = pic; state->pic = pic;
@ -74,8 +74,8 @@ new_analyze_state(pic_state *pic)
register_renamed_symbol(pic, state, rCAR, pic->PICRIN_BASE, "car"); register_renamed_symbol(pic, state, rCAR, pic->PICRIN_BASE, "car");
register_renamed_symbol(pic, state, rCDR, pic->PICRIN_BASE, "cdr"); register_renamed_symbol(pic, state, rCDR, pic->PICRIN_BASE, "cdr");
register_renamed_symbol(pic, state, rNILP, pic->PICRIN_BASE, "null?"); register_renamed_symbol(pic, state, rNILP, pic->PICRIN_BASE, "null?");
register_renamed_symbol(pic, state, rSYMBOL_P, pic->PICRIN_BASE, "symbol?"); register_renamed_symbol(pic, state, rSYMBOLP, pic->PICRIN_BASE, "symbol?");
register_renamed_symbol(pic, state, rPAIR_P, pic->PICRIN_BASE, "pair?"); register_renamed_symbol(pic, state, rPAIRP, pic->PICRIN_BASE, "pair?");
register_renamed_symbol(pic, state, rADD, pic->PICRIN_BASE, "+"); register_renamed_symbol(pic, state, rADD, pic->PICRIN_BASE, "+");
register_renamed_symbol(pic, state, rSUB, pic->PICRIN_BASE, "-"); register_renamed_symbol(pic, state, rSUB, pic->PICRIN_BASE, "-");
register_renamed_symbol(pic, state, rMUL, pic->PICRIN_BASE, "*"); register_renamed_symbol(pic, state, rMUL, pic->PICRIN_BASE, "*");
@ -89,20 +89,10 @@ new_analyze_state(pic_state *pic)
register_renamed_symbol(pic, state, rVALUES, pic->PICRIN_BASE, "values"); register_renamed_symbol(pic, state, rVALUES, pic->PICRIN_BASE, "values");
register_renamed_symbol(pic, state, rCALL_WITH_VALUES, pic->PICRIN_BASE, "call-with-values"); register_renamed_symbol(pic, state, rCALL_WITH_VALUES, pic->PICRIN_BASE, "call-with-values");
register_symbol(pic, state, sCALL, "call");
register_symbol(pic, state, sTAILCALL, "tail-call");
register_symbol(pic, state, sCALL_WITH_VALUES, "call-with-values");
register_symbol(pic, state, sTAILCALL_WITH_VALUES, "tailcall-with-values");
register_symbol(pic, state, sGREF, "gref");
register_symbol(pic, state, sLREF, "lref");
register_symbol(pic, state, sCREF, "cref");
register_symbol(pic, state, sRETURN, "return");
/* push initial scope */ /* push initial scope */
push_scope(state, pic_nil_value()); push_scope(state, pic_nil_value());
for (it = xh_begin(&pic->globals); it != NULL; it = xh_next(it)) { pic_dict_for_each (sym, pic->globals) {
pic_sym sym = xh_key(it, pic_sym);
xv_push(&state->scope->locals, &sym); xv_push(&state->scope->locals, &sym);
} }
@ -120,14 +110,14 @@ static bool
analyze_args(pic_state *pic, pic_value formals, bool *varg, xvect *args, xvect *locals) analyze_args(pic_state *pic, pic_value formals, bool *varg, xvect *args, xvect *locals)
{ {
pic_value v, t; pic_value v, t;
pic_sym sym; pic_sym *sym;
for (v = formals; pic_pair_p(v); v = pic_cdr(pic, v)) { for (v = formals; pic_pair_p(v); v = pic_cdr(pic, v)) {
t = pic_car(pic, v); t = pic_car(pic, v);
if (! pic_sym_p(t)) { if (! pic_sym_p(t)) {
return false; return false;
} }
sym = pic_sym(t); sym = pic_sym_ptr(t);
xv_push(args, &sym); xv_push(args, &sym);
} }
if (pic_nil_p(v)) { if (pic_nil_p(v)) {
@ -135,7 +125,7 @@ analyze_args(pic_state *pic, pic_value formals, bool *varg, xvect *args, xvect *
} }
else if (pic_sym_p(v)) { else if (pic_sym_p(v)) {
*varg = true; *varg = true;
sym = pic_sym(v); sym = pic_sym_ptr(v);
xv_push(locals, &sym); xv_push(locals, &sym);
} }
else { else {
@ -153,9 +143,9 @@ push_scope(analyze_state *state, pic_value formals)
bool varg; bool varg;
xvect args, locals, captures; xvect args, locals, captures;
xv_init(&args, sizeof(pic_sym)); xv_init(&args, sizeof(pic_sym *));
xv_init(&locals, sizeof(pic_sym)); xv_init(&locals, sizeof(pic_sym *));
xv_init(&captures, sizeof(pic_sym)); xv_init(&captures, sizeof(pic_sym *));
if (analyze_args(pic, formals, &varg, &args, &locals)) { if (analyze_args(pic, formals, &varg, &args, &locals)) {
scope = pic_alloc(pic, sizeof(analyze_scope)); scope = pic_alloc(pic, sizeof(analyze_scope));
@ -194,9 +184,9 @@ pop_scope(analyze_state *state)
} }
static bool static bool
lookup_scope(analyze_scope *scope, pic_sym sym) lookup_scope(analyze_scope *scope, pic_sym *sym)
{ {
pic_sym *arg, *local; pic_sym **arg, **local;
size_t i; size_t i;
/* args */ /* args */
@ -215,9 +205,9 @@ lookup_scope(analyze_scope *scope, pic_sym sym)
} }
static void static void
capture_var(analyze_scope *scope, pic_sym sym) capture_var(analyze_scope *scope, pic_sym *sym)
{ {
pic_sym *var; pic_sym **var;
size_t i; size_t i;
for (i = 0; i < xv_size(&scope->captures); ++i) { for (i = 0; i < xv_size(&scope->captures); ++i) {
@ -232,7 +222,7 @@ capture_var(analyze_scope *scope, pic_sym sym)
} }
static int static int
find_var(analyze_state *state, pic_sym sym) find_var(analyze_state *state, pic_sym *sym)
{ {
analyze_scope *scope = state->scope; analyze_scope *scope = state->scope;
int depth = 0; int depth = 0;
@ -251,13 +241,13 @@ find_var(analyze_state *state, pic_sym sym)
} }
static void static void
define_var(analyze_state *state, pic_sym sym) define_var(analyze_state *state, pic_sym *sym)
{ {
pic_state *pic = state->pic; pic_state *pic = state->pic;
analyze_scope *scope = state->scope; analyze_scope *scope = state->scope;
if (lookup_scope(scope, sym)) { if (lookup_scope(scope, sym)) {
pic_warnf(pic, "redefining variable: ~s", pic_sym_value(sym)); pic_warnf(pic, "redefining variable: ~s", pic_obj_value(sym));
return; return;
} }
@ -273,17 +263,17 @@ analyze(analyze_state *state, pic_value obj, bool tailpos)
pic_state *pic = state->pic; pic_state *pic = state->pic;
size_t ai = pic_gc_arena_preserve(pic); size_t ai = pic_gc_arena_preserve(pic);
pic_value res; pic_value res;
pic_sym tag; pic_sym *tag;
res = analyze_node(state, obj, tailpos); res = analyze_node(state, obj, tailpos);
tag = pic_sym(pic_car(pic, res)); tag = pic_sym_ptr(pic_car(pic, res));
if (tailpos) { if (tailpos) {
if (tag == pic->sIF || tag == pic->sBEGIN || tag == state->sTAILCALL || tag == state->sTAILCALL_WITH_VALUES || tag == state->sRETURN) { if (tag == pic->sIF || tag == pic->sBEGIN || tag == pic->sTAILCALL || tag == pic->sTAILCALL_WITH_VALUES || tag == pic->sRETURN) {
/* pass through */ /* pass through */
} }
else { else {
res = pic_list2(pic, pic_symbol_value(state->sRETURN), res); res = pic_list2(pic, pic_obj_value(pic->sRETURN), res);
} }
} }
@ -294,31 +284,31 @@ analyze(analyze_state *state, pic_value obj, bool tailpos)
} }
static pic_value static pic_value
analyze_global_var(analyze_state *state, pic_sym sym) analyze_global_var(analyze_state *state, pic_sym *sym)
{ {
pic_state *pic = state->pic; pic_state *pic = state->pic;
return pic_list2(pic, pic_symbol_value(state->sGREF), pic_sym_value(sym)); return pic_list2(pic, pic_obj_value(pic->sGREF), pic_obj_value(sym));
} }
static pic_value static pic_value
analyze_local_var(analyze_state *state, pic_sym sym) analyze_local_var(analyze_state *state, pic_sym *sym)
{ {
pic_state *pic = state->pic; pic_state *pic = state->pic;
return pic_list2(pic, pic_symbol_value(state->sLREF), pic_sym_value(sym)); return pic_list2(pic, pic_obj_value(pic->sLREF), pic_obj_value(sym));
} }
static pic_value static pic_value
analyze_free_var(analyze_state *state, pic_sym sym, int depth) analyze_free_var(analyze_state *state, pic_sym *sym, int depth)
{ {
pic_state *pic = state->pic; pic_state *pic = state->pic;
return pic_list3(pic, pic_symbol_value(state->sCREF), pic_int_value(depth), pic_sym_value(sym)); return pic_list3(pic, pic_obj_value(pic->sCREF), pic_int_value(depth), pic_obj_value(sym));
} }
static pic_value static pic_value
analyze_var(analyze_state *state, pic_sym sym) analyze_var(analyze_state *state, pic_sym *sym)
{ {
pic_state *pic = state->pic; pic_state *pic = state->pic;
int depth; int depth;
@ -340,10 +330,10 @@ static pic_value
analyze_defer(analyze_state *state, pic_value name, pic_value formal, pic_value body) analyze_defer(analyze_state *state, pic_value name, pic_value formal, pic_value body)
{ {
pic_state *pic = state->pic; pic_state *pic = state->pic;
const pic_sym sNOWHERE = pic_intern_cstr(pic, " nowhere "); pic_sym *sNOWHERE = pic_intern_cstr(pic, "<<nowhere>>");
pic_value skel; pic_value skel;
skel = pic_list2(pic, pic_sym_value(state->sGREF), pic_sym_value(sNOWHERE)); skel = pic_list2(pic, pic_obj_value(pic->sGREF), pic_obj_value(sNOWHERE));
pic_push(pic, pic_list4(pic, name, formal, body, skel), state->scope->defer); pic_push(pic, pic_list4(pic, name, formal, body, skel), state->scope->defer);
@ -382,13 +372,13 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v
if (push_scope(state, formals)) { if (push_scope(state, formals)) {
analyze_scope *scope = state->scope; analyze_scope *scope = state->scope;
pic_sym *var; pic_sym **var;
size_t i; size_t i;
args = pic_nil_value(); args = pic_nil_value();
for (i = xv_size(&scope->args); i > 0; --i) { for (i = xv_size(&scope->args); i > 0; --i) {
var = xv_get(&scope->args, i - 1); var = xv_get(&scope->args, i - 1);
pic_push(pic, pic_sym_value(*var), args); pic_push(pic, pic_obj_value(*var), args);
} }
varg = scope->varg varg = scope->varg
@ -396,20 +386,20 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v
: pic_false_value(); : pic_false_value();
/* To know what kind of local variables are defined, analyze body at first. */ /* To know what kind of local variables are defined, analyze body at first. */
body = analyze(state, pic_cons(pic, pic_sym_value(pic->rBEGIN), body_exprs), true); body = analyze(state, pic_cons(pic, pic_obj_value(pic->rBEGIN), body_exprs), true);
analyze_deferred(state); analyze_deferred(state);
locals = pic_nil_value(); locals = pic_nil_value();
for (i = xv_size(&scope->locals); i > 0; --i) { for (i = xv_size(&scope->locals); i > 0; --i) {
var = xv_get(&scope->locals, i - 1); var = xv_get(&scope->locals, i - 1);
pic_push(pic, pic_sym_value(*var), locals); pic_push(pic, pic_obj_value(*var), locals);
} }
captures = pic_nil_value(); captures = pic_nil_value();
for (i = xv_size(&scope->captures); i > 0; --i) { for (i = xv_size(&scope->captures); i > 0; --i) {
var = xv_get(&scope->captures, i - 1); var = xv_get(&scope->captures, i - 1);
pic_push(pic, pic_sym_value(*var), captures); pic_push(pic, pic_obj_value(*var), captures);
} }
pop_scope(state); pop_scope(state);
@ -418,7 +408,7 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v
pic_errorf(pic, "invalid formal syntax: ~s", args); pic_errorf(pic, "invalid formal syntax: ~s", args);
} }
return pic_list7(pic, pic_sym_value(pic->sLAMBDA), name, args, locals, varg, captures, body); return pic_list7(pic, pic_obj_value(pic->sLAMBDA), name, args, locals, varg, captures, body);
} }
static pic_value static pic_value
@ -438,7 +428,7 @@ analyze_lambda(analyze_state *state, pic_value obj)
} }
static pic_value static pic_value
analyze_declare(analyze_state *state, pic_sym var) analyze_declare(analyze_state *state, pic_sym *var)
{ {
define_var(state, var); define_var(state, var);
@ -450,7 +440,7 @@ analyze_define(analyze_state *state, pic_value obj)
{ {
pic_state *pic = state->pic; pic_state *pic = state->pic;
pic_value var, val; pic_value var, val;
pic_sym sym; pic_sym *sym;
if (pic_length(pic, obj) != 3) { if (pic_length(pic, obj) != 3) {
pic_errorf(pic, "syntax error"); pic_errorf(pic, "syntax error");
@ -460,19 +450,19 @@ analyze_define(analyze_state *state, pic_value obj)
if (! pic_sym_p(var)) { if (! pic_sym_p(var)) {
pic_errorf(pic, "syntax error"); pic_errorf(pic, "syntax error");
} else { } else {
sym = pic_sym(var); sym = pic_sym_ptr(var);
} }
var = analyze_declare(state, sym); var = analyze_declare(state, sym);
if (pic_pair_p(pic_list_ref(pic, obj, 2)) if (pic_pair_p(pic_list_ref(pic, obj, 2))
&& pic_sym_p(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) && pic_sym_p(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0))
&& pic_sym(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->rLAMBDA) { && pic_sym_ptr(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->rLAMBDA) {
pic_value formals, body_exprs; pic_value formals, body_exprs;
formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1); formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1);
body_exprs = pic_list_tail(pic, pic_list_ref(pic, obj, 2), 2); body_exprs = pic_list_tail(pic, pic_list_ref(pic, obj, 2), 2);
val = analyze_defer(state, pic_sym_value(sym), formals, body_exprs); val = analyze_defer(state, pic_obj_value(sym), formals, body_exprs);
} else { } else {
if (pic_length(pic, obj) != 3) { if (pic_length(pic, obj) != 3) {
pic_errorf(pic, "syntax error"); pic_errorf(pic, "syntax error");
@ -480,7 +470,7 @@ analyze_define(analyze_state *state, pic_value obj)
val = analyze(state, pic_list_ref(pic, obj, 2), false); val = analyze(state, pic_list_ref(pic, obj, 2), false);
} }
return pic_list3(pic, pic_symbol_value(pic->sSETBANG), var, val); return pic_list3(pic, pic_obj_value(pic->sSETBANG), var, val);
} }
static pic_value static pic_value
@ -505,7 +495,7 @@ analyze_if(analyze_state *state, pic_value obj, bool tailpos)
if_true = analyze(state, if_true, tailpos); if_true = analyze(state, if_true, tailpos);
if_false = analyze(state, if_false, tailpos); if_false = analyze(state, if_false, tailpos);
return pic_list4(pic, pic_symbol_value(pic->sIF), cond, if_true, if_false); return pic_list4(pic, pic_obj_value(pic->sIF), cond, if_true, if_false);
} }
static pic_value static pic_value
@ -521,7 +511,7 @@ analyze_begin(analyze_state *state, pic_value obj, bool tailpos)
case 2: case 2:
return analyze(state, pic_list_ref(pic, obj, 1), tailpos); return analyze(state, pic_list_ref(pic, obj, 1), tailpos);
default: default:
seq = pic_list1(pic, pic_symbol_value(pic->sBEGIN)); seq = pic_list1(pic, pic_obj_value(pic->sBEGIN));
for (obj = pic_cdr(pic, obj); ! pic_nil_p(obj); obj = pic_cdr(pic, obj)) { for (obj = pic_cdr(pic, obj); ! pic_nil_p(obj); obj = pic_cdr(pic, obj)) {
if (pic_nil_p(pic_cdr(pic, obj))) { if (pic_nil_p(pic_cdr(pic, obj))) {
tail = tailpos; tail = tailpos;
@ -554,7 +544,7 @@ analyze_set(analyze_state *state, pic_value obj)
var = analyze(state, var, false); var = analyze(state, var, false);
val = analyze(state, val, false); val = analyze(state, val, false);
return pic_list3(pic, pic_symbol_value(pic->sSETBANG), var, val); return pic_list3(pic, pic_obj_value(pic->sSETBANG), var, val);
} }
static pic_value static pic_value
@ -565,22 +555,22 @@ analyze_quote(analyze_state *state, pic_value obj)
if (pic_length(pic, obj) != 2) { if (pic_length(pic, obj) != 2) {
pic_errorf(pic, "syntax error"); pic_errorf(pic, "syntax error");
} }
return pic_list2(pic, pic_sym_value(pic->sQUOTE), pic_list_ref(pic, obj, 1)); return pic_list2(pic, pic_obj_value(pic->sQUOTE), pic_list_ref(pic, obj, 1));
} }
#define ARGC_ASSERT_GE(n) do { \ #define ARGC_ASSERT_GE(n) do { \
if (pic_length(pic, obj) < (n) + 1) { \ if (pic_length(pic, obj) < (n) + 1) { \
pic_errorf(pic, "wrong number of arguments"); \ pic_errorf(pic, "wrong number of arguments"); \
} \ } \
} while (0) } while (0)
#define FOLD_ARGS(sym) do { \ #define FOLD_ARGS(sym) do { \
obj = analyze(state, pic_car(pic, args), false); \ obj = analyze(state, pic_car(pic, args), false); \
pic_for_each (arg, pic_cdr(pic, args)) { \ pic_for_each (arg, pic_cdr(pic, args)) { \
obj = pic_list3(pic, pic_symbol_value(sym), obj, \ obj = pic_list3(pic, pic_obj_value(sym), obj, \
analyze(state, arg, false)); \ analyze(state, arg, false)); \
} \ } \
} while (0) } while (0)
static pic_value static pic_value
analyze_add(analyze_state *state, pic_value obj, bool tailpos) analyze_add(analyze_state *state, pic_value obj, bool tailpos)
@ -591,7 +581,7 @@ analyze_add(analyze_state *state, pic_value obj, bool tailpos)
ARGC_ASSERT_GE(0); ARGC_ASSERT_GE(0);
switch (pic_length(pic, obj)) { switch (pic_length(pic, obj)) {
case 1: case 1:
return pic_list2(pic, pic_symbol_value(pic->sQUOTE), pic_int_value(0)); return pic_list2(pic, pic_obj_value(pic->sQUOTE), pic_int_value(0));
case 2: case 2:
return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos); return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos);
default: default:
@ -610,7 +600,7 @@ analyze_sub(analyze_state *state, pic_value obj)
ARGC_ASSERT_GE(1); ARGC_ASSERT_GE(1);
switch (pic_length(pic, obj)) { switch (pic_length(pic, obj)) {
case 2: case 2:
return pic_list2(pic, pic_symbol_value(pic->sMINUS), return pic_list2(pic, pic_obj_value(pic->sMINUS),
analyze(state, pic_car(pic, pic_cdr(pic, obj)), false)); analyze(state, pic_car(pic, pic_cdr(pic, obj)), false));
default: default:
args = pic_cdr(pic, obj); args = pic_cdr(pic, obj);
@ -628,7 +618,7 @@ analyze_mul(analyze_state *state, pic_value obj, bool tailpos)
ARGC_ASSERT_GE(0); ARGC_ASSERT_GE(0);
switch (pic_length(pic, obj)) { switch (pic_length(pic, obj)) {
case 1: case 1:
return pic_list2(pic, pic_symbol_value(pic->sQUOTE), pic_int_value(1)); return pic_list2(pic, pic_obj_value(pic->sQUOTE), pic_int_value(1));
case 2: case 2:
return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos); return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos);
default: default:
@ -662,14 +652,14 @@ analyze_call(analyze_state *state, pic_value obj, bool tailpos)
{ {
pic_state *pic = state->pic; pic_state *pic = state->pic;
pic_value seq, elt; pic_value seq, elt;
pic_sym call; pic_sym *call;
if (! tailpos) { if (! tailpos) {
call = state->sCALL; call = pic->sCALL;
} else { } else {
call = state->sTAILCALL; call = pic->sTAILCALL;
} }
seq = pic_list1(pic, pic_symbol_value(call)); seq = pic_list1(pic, pic_obj_value(call));
pic_for_each (elt, obj) { pic_for_each (elt, obj) {
seq = pic_cons(pic, analyze(state, elt, false), seq); seq = pic_cons(pic, analyze(state, elt, false), seq);
} }
@ -686,7 +676,7 @@ analyze_values(analyze_state *state, pic_value obj, bool tailpos)
return analyze_call(state, obj, false); return analyze_call(state, obj, false);
} }
seq = pic_list1(pic, pic_symbol_value(state->sRETURN)); seq = pic_list1(pic, pic_obj_value(pic->sRETURN));
pic_for_each (v, pic_cdr(pic, obj)) { pic_for_each (v, pic_cdr(pic, obj)) {
seq = pic_cons(pic, analyze(state, v, false), seq); seq = pic_cons(pic, analyze(state, v, false), seq);
} }
@ -698,44 +688,44 @@ analyze_call_with_values(analyze_state *state, pic_value obj, bool tailpos)
{ {
pic_state *pic = state->pic; pic_state *pic = state->pic;
pic_value prod, cnsm; pic_value prod, cnsm;
pic_sym call; pic_sym *call;
if (pic_length(pic, obj) != 3) { if (pic_length(pic, obj) != 3) {
pic_errorf(pic, "wrong number of arguments"); pic_errorf(pic, "wrong number of arguments");
} }
if (! tailpos) { if (! tailpos) {
call = state->sCALL_WITH_VALUES; call = pic->sCALL_WITH_VALUES;
} else { } else {
call = state->sTAILCALL_WITH_VALUES; call = pic->sTAILCALL_WITH_VALUES;
} }
prod = analyze(state, pic_list_ref(pic, obj, 1), false); prod = analyze(state, pic_list_ref(pic, obj, 1), false);
cnsm = analyze(state, pic_list_ref(pic, obj, 2), false); cnsm = analyze(state, pic_list_ref(pic, obj, 2), false);
return pic_list3(pic, pic_symbol_value(call), prod, cnsm); return pic_list3(pic, pic_obj_value(call), prod, cnsm);
} }
#define ARGC_ASSERT(n) do { \ #define ARGC_ASSERT(n) do { \
if (pic_length(pic, obj) != (n) + 1) { \ if (pic_length(pic, obj) != (n) + 1) { \
pic_errorf(pic, "wrong number of arguments"); \ pic_errorf(pic, "wrong number of arguments"); \
} \ } \
} while (0) } while (0)
#define ARGC_ASSERT_WITH_FALLBACK(n) do { \ #define ARGC_ASSERT_WITH_FALLBACK(n) do { \
if (pic_length(pic, obj) != (n) + 1) { \ if (pic_length(pic, obj) != (n) + 1) { \
goto fallback; \ goto fallback; \
} \ } \
} while (0) } while (0)
#define CONSTRUCT_OP1(op) \ #define CONSTRUCT_OP1(op) \
pic_list2(pic, \ pic_list2(pic, \
pic_symbol_value(op), \ pic_obj_value(op), \
analyze(state, pic_list_ref(pic, obj, 1), false)) analyze(state, pic_list_ref(pic, obj, 1), false))
#define CONSTRUCT_OP2(op) \ #define CONSTRUCT_OP2(op) \
pic_list3(pic, \ pic_list3(pic, \
pic_symbol_value(op), \ pic_obj_value(op), \
analyze(state, pic_list_ref(pic, obj, 1), false), \ analyze(state, pic_list_ref(pic, obj, 1), false), \
analyze(state, pic_list_ref(pic, obj, 2), false)) analyze(state, pic_list_ref(pic, obj, 2), false))
static pic_value static pic_value
analyze_node(analyze_state *state, pic_value obj, bool tailpos) analyze_node(analyze_state *state, pic_value obj, bool tailpos)
@ -744,7 +734,7 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
switch (pic_type(obj)) { switch (pic_type(obj)) {
case PIC_TT_SYMBOL: { case PIC_TT_SYMBOL: {
return analyze_var(state, pic_sym(obj)); return analyze_var(state, pic_sym_ptr(obj));
} }
case PIC_TT_PAIR: { case PIC_TT_PAIR: {
pic_value proc; pic_value proc;
@ -755,7 +745,7 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
proc = pic_list_ref(pic, obj, 0); proc = pic_list_ref(pic, obj, 0);
if (pic_sym_p(proc)) { if (pic_sym_p(proc)) {
pic_sym sym = pic_sym(proc); pic_sym *sym = pic_sym_ptr(proc);
if (sym == pic->rDEFINE) { if (sym == pic->rDEFINE) {
return analyze_define(state, obj); return analyze_define(state, obj);
@ -791,13 +781,13 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
ARGC_ASSERT(1); ARGC_ASSERT(1);
return CONSTRUCT_OP1(pic->sNILP); return CONSTRUCT_OP1(pic->sNILP);
} }
else if (sym == state->rSYMBOL_P) { else if (sym == state->rSYMBOLP) {
ARGC_ASSERT(1); ARGC_ASSERT(1);
return CONSTRUCT_OP1(pic->sSYMBOL_P); return CONSTRUCT_OP1(pic->sSYMBOLP);
} }
else if (sym == state->rPAIR_P) { else if (sym == state->rPAIRP) {
ARGC_ASSERT(1); ARGC_ASSERT(1);
return CONSTRUCT_OP1(pic->sPAIR_P); return CONSTRUCT_OP1(pic->sPAIRP);
} }
else if (sym == state->rADD) { else if (sym == state->rADD) {
return analyze_add(state, obj, tailpos); return analyze_add(state, obj, tailpos);
@ -842,12 +832,12 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
return analyze_call_with_values(state, obj, tailpos); return analyze_call_with_values(state, obj, tailpos);
} }
} }
fallback: fallback:
return analyze_call(state, obj, tailpos); return analyze_call(state, obj, tailpos);
} }
default: default:
return pic_list2(pic, pic_symbol_value(pic->sQUOTE), obj); return pic_list2(pic, pic_obj_value(pic->sQUOTE), obj);
} }
} }
@ -871,7 +861,7 @@ pic_analyze(pic_state *pic, pic_value obj)
*/ */
typedef struct codegen_context { typedef struct codegen_context {
pic_sym name; pic_sym *name;
/* rest args variable is counted as a local */ /* rest args variable is counted as a local */
bool varg; bool varg;
xvect args, locals, captures; xvect args, locals, captures;
@ -884,6 +874,9 @@ typedef struct codegen_context {
/* constant object pool */ /* constant object pool */
pic_value *pool; pic_value *pool;
size_t plen, pcapa; size_t plen, pcapa;
/* symbol pool */
pic_sym **syms;
size_t slen, scapa;
struct codegen_context *up; struct codegen_context *up;
} codegen_context; } codegen_context;
@ -895,9 +888,6 @@ typedef struct codegen_context {
typedef struct codegen_state { typedef struct codegen_state {
pic_state *pic; pic_state *pic;
codegen_context *cxt; codegen_context *cxt;
pic_sym sGREF, sCREF, sLREF;
pic_sym sCALL, sTAILCALL, sRETURN;
pic_sym sCALL_WITH_VALUES, sTAILCALL_WITH_VALUES;
} codegen_state; } codegen_state;
static void push_codegen_context(codegen_state *, pic_value, pic_value, pic_value, bool, pic_value); static void push_codegen_context(codegen_state *, pic_value, pic_value, pic_value, bool, pic_value);
@ -912,15 +902,6 @@ new_codegen_state(pic_state *pic)
state->pic = pic; state->pic = pic;
state->cxt = NULL; state->cxt = NULL;
register_symbol(pic, state, sCALL, "call");
register_symbol(pic, state, sTAILCALL, "tail-call");
register_symbol(pic, state, sGREF, "gref");
register_symbol(pic, state, sLREF, "lref");
register_symbol(pic, state, sCREF, "cref");
register_symbol(pic, state, sRETURN, "return");
register_symbol(pic, state, sCALL_WITH_VALUES, "call-with-values");
register_symbol(pic, state, sTAILCALL_WITH_VALUES, "tailcall-with-values");
push_codegen_context(state, pic_false_value(), pic_nil_value(), pic_nil_value(), false, pic_nil_value()); push_codegen_context(state, pic_false_value(), pic_nil_value(), pic_nil_value(), false, pic_nil_value());
return state; return state;
@ -943,27 +924,27 @@ create_activation(codegen_context *cxt)
{ {
size_t i, n; size_t i, n;
xhash regs; xhash regs;
pic_sym *var; pic_sym **var;
size_t offset; size_t offset;
xh_init_int(&regs, sizeof(size_t)); xh_init_ptr(&regs, sizeof(size_t));
offset = 1; offset = 1;
for (i = 0; i < xv_size(&cxt->args); ++i) { for (i = 0; i < xv_size(&cxt->args); ++i) {
var = xv_get(&cxt->args, i); var = xv_get(&cxt->args, i);
n = i + offset; n = i + offset;
xh_put_int(&regs, *var, &n); xh_put_ptr(&regs, *var, &n);
} }
offset += i; offset += i;
for (i = 0; i < xv_size(&cxt->locals); ++i) { for (i = 0; i < xv_size(&cxt->locals); ++i) {
var = xv_get(&cxt->locals, i); var = xv_get(&cxt->locals, i);
n = i + offset; n = i + offset;
xh_put_int(&regs, *var, &n); xh_put_ptr(&regs, *var, &n);
} }
for (i = 0; i < xv_size(&cxt->captures); ++i) { for (i = 0; i < xv_size(&cxt->captures); ++i) {
var = xv_get(&cxt->captures, i); var = xv_get(&cxt->captures, i);
if ((n = xh_val(xh_get_int(&regs, *var), size_t)) <= xv_size(&cxt->args) || (cxt->varg && n == xv_size(&cxt->args) + 1)) { if ((n = xh_val(xh_get_ptr(&regs, *var), size_t)) <= xv_size(&cxt->args) || (cxt->varg && n == xv_size(&cxt->args) + 1)) {
/* copy arguments to capture variable area */ /* copy arguments to capture variable area */
cxt->code[cxt->clen].insn = OP_LREF; cxt->code[cxt->clen].insn = OP_LREF;
cxt->code[cxt->clen].u.i = (int)n; cxt->code[cxt->clen].u.i = (int)n;
@ -984,7 +965,7 @@ push_codegen_context(codegen_state *state, pic_value name, pic_value args, pic_v
pic_state *pic = state->pic; pic_state *pic = state->pic;
codegen_context *cxt; codegen_context *cxt;
pic_value var; pic_value var;
pic_sym sym; pic_sym *sym;
assert(pic_sym_p(name) || pic_false_p(name)); assert(pic_sym_p(name) || pic_false_p(name));
@ -992,23 +973,23 @@ push_codegen_context(codegen_state *state, pic_value name, pic_value args, pic_v
cxt->up = state->cxt; cxt->up = state->cxt;
cxt->name = pic_false_p(name) cxt->name = pic_false_p(name)
? pic_intern_cstr(pic, "(anonymous lambda)") ? pic_intern_cstr(pic, "(anonymous lambda)")
: pic_sym(name); : pic_sym_ptr(name);
cxt->varg = varg; cxt->varg = varg;
xv_init(&cxt->args, sizeof(pic_sym)); xv_init(&cxt->args, sizeof(pic_sym *));
xv_init(&cxt->locals, sizeof(pic_sym)); xv_init(&cxt->locals, sizeof(pic_sym *));
xv_init(&cxt->captures, sizeof(pic_sym)); xv_init(&cxt->captures, sizeof(pic_sym *));
pic_for_each (var, args) { pic_for_each (var, args) {
sym = pic_sym(var); sym = pic_sym_ptr(var);
xv_push(&cxt->args, &sym); xv_push(&cxt->args, &sym);
} }
pic_for_each (var, locals) { pic_for_each (var, locals) {
sym = pic_sym(var); sym = pic_sym_ptr(var);
xv_push(&cxt->locals, &sym); xv_push(&cxt->locals, &sym);
} }
pic_for_each (var, captures) { pic_for_each (var, captures) {
sym = pic_sym(var); sym = pic_sym_ptr(var);
xv_push(&cxt->captures, &sym); xv_push(&cxt->captures, &sym);
} }
@ -1024,6 +1005,10 @@ push_codegen_context(codegen_state *state, pic_value name, pic_value args, pic_v
cxt->plen = 0; cxt->plen = 0;
cxt->pcapa = PIC_POOL_SIZE; cxt->pcapa = PIC_POOL_SIZE;
cxt->syms = pic_calloc(pic, PIC_POOL_SIZE, sizeof(pic_sym *));
cxt->slen = 0;
cxt->scapa = PIC_POOL_SIZE;
state->cxt = cxt; state->cxt = cxt;
create_activation(cxt); create_activation(cxt);
@ -1049,6 +1034,8 @@ pop_codegen_context(codegen_state *state)
irep->ilen = state->cxt->ilen; irep->ilen = state->cxt->ilen;
irep->pool = pic_realloc(pic, state->cxt->pool, sizeof(pic_value) * state->cxt->plen); irep->pool = pic_realloc(pic, state->cxt->pool, sizeof(pic_value) * state->cxt->plen);
irep->plen = state->cxt->plen; irep->plen = state->cxt->plen;
irep->syms = pic_realloc(pic, state->cxt->syms, sizeof(pic_sym *) * state->cxt->slen);
irep->slen = state->cxt->slen;
/* finalize */ /* finalize */
xv_destroy(&cxt->args); xv_destroy(&cxt->args);
@ -1064,11 +1051,11 @@ pop_codegen_context(codegen_state *state)
} }
static int static int
index_capture(codegen_state *state, pic_sym sym, int depth) index_capture(codegen_state *state, pic_sym *sym, int depth)
{ {
codegen_context *cxt = state->cxt; codegen_context *cxt = state->cxt;
size_t i; size_t i;
pic_sym *var; pic_sym **var;
while (depth-- > 0) { while (depth-- > 0) {
cxt = cxt->up; cxt = cxt->up;
@ -1083,11 +1070,11 @@ index_capture(codegen_state *state, pic_sym sym, int depth)
} }
static int static int
index_local(codegen_state *state, pic_sym sym) index_local(codegen_state *state, pic_sym *sym)
{ {
codegen_context *cxt = state->cxt; codegen_context *cxt = state->cxt;
size_t i, offset; size_t i, offset;
pic_sym *var; pic_sym **var;
offset = 1; offset = 1;
for (i = 0; i < xv_size(&cxt->args); ++i) { for (i = 0; i < xv_size(&cxt->args); ++i) {
@ -1104,6 +1091,26 @@ index_local(codegen_state *state, pic_sym sym)
return -1; return -1;
} }
static int
index_symbol(codegen_state *state, pic_sym *sym)
{
pic_state *pic = state->pic;
codegen_context *cxt = state->cxt;
size_t i;
for (i = 0; i < cxt->slen; ++i) {
if (cxt->syms[i] == sym) {
return i;
}
}
if (cxt->slen >= cxt->scapa) {
cxt->scapa *= 2;
cxt->syms = pic_realloc(pic, cxt->syms, sizeof(pic_sym *) * cxt->scapa);
}
cxt->syms[cxt->slen++] = sym;
return i;
}
static struct pic_irep *codegen_lambda(codegen_state *, pic_value); static struct pic_irep *codegen_lambda(codegen_state *, pic_value);
static void static void
@ -1111,30 +1118,30 @@ codegen(codegen_state *state, pic_value obj)
{ {
pic_state *pic = state->pic; pic_state *pic = state->pic;
codegen_context *cxt = state->cxt; codegen_context *cxt = state->cxt;
pic_sym sym; pic_sym *sym;
sym = pic_sym(pic_car(pic, obj)); sym = pic_sym_ptr(pic_car(pic, obj));
if (sym == state->sGREF) { if (sym == pic->sGREF) {
cxt->code[cxt->clen].insn = OP_GREF; cxt->code[cxt->clen].insn = OP_GREF;
cxt->code[cxt->clen].u.i = pic_sym(pic_list_ref(pic, obj, 1)); cxt->code[cxt->clen].u.i = index_symbol(state, pic_sym_ptr(pic_list_ref(pic, obj, 1)));
cxt->clen++; cxt->clen++;
return; return;
} else if (sym == state->sCREF) { } else if (sym == pic->sCREF) {
pic_sym name; pic_sym *name;
int depth; int depth;
depth = pic_int(pic_list_ref(pic, obj, 1)); depth = pic_int(pic_list_ref(pic, obj, 1));
name = pic_sym(pic_list_ref(pic, obj, 2)); name = pic_sym_ptr(pic_list_ref(pic, obj, 2));
cxt->code[cxt->clen].insn = OP_CREF; cxt->code[cxt->clen].insn = OP_CREF;
cxt->code[cxt->clen].u.r.depth = depth; cxt->code[cxt->clen].u.r.depth = depth;
cxt->code[cxt->clen].u.r.idx = index_capture(state, name, depth); cxt->code[cxt->clen].u.r.idx = index_capture(state, name, depth);
cxt->clen++; cxt->clen++;
return; return;
} else if (sym == state->sLREF) { } else if (sym == pic->sLREF) {
pic_sym name; pic_sym *name;
int i; int i;
name = pic_sym(pic_list_ref(pic, obj, 1)); name = pic_sym_ptr(pic_list_ref(pic, obj, 1));
if ((i = index_capture(state, name, 0)) != -1) { if ((i = index_capture(state, name, 0)) != -1) {
cxt->code[cxt->clen].insn = OP_LREF; cxt->code[cxt->clen].insn = OP_LREF;
cxt->code[cxt->clen].u.i = i + (int)xv_size(&cxt->args) + (int)xv_size(&cxt->locals) + 1; cxt->code[cxt->clen].u.i = i + (int)xv_size(&cxt->args) + (int)xv_size(&cxt->locals) + 1;
@ -1147,27 +1154,27 @@ codegen(codegen_state *state, pic_value obj)
return; return;
} else if (sym == pic->sSETBANG) { } else if (sym == pic->sSETBANG) {
pic_value var, val; pic_value var, val;
pic_sym type; pic_sym *type;
val = pic_list_ref(pic, obj, 2); val = pic_list_ref(pic, obj, 2);
codegen(state, val); codegen(state, val);
var = pic_list_ref(pic, obj, 1); var = pic_list_ref(pic, obj, 1);
type = pic_sym(pic_list_ref(pic, var, 0)); type = pic_sym_ptr(pic_list_ref(pic, var, 0));
if (type == state->sGREF) { if (type == pic->sGREF) {
cxt->code[cxt->clen].insn = OP_GSET; cxt->code[cxt->clen].insn = OP_GSET;
cxt->code[cxt->clen].u.i = pic_int(pic_list_ref(pic, var, 1)); cxt->code[cxt->clen].u.i = index_symbol(state, pic_sym_ptr(pic_list_ref(pic, var, 1)));
cxt->clen++; cxt->clen++;
cxt->code[cxt->clen].insn = OP_PUSHNONE; cxt->code[cxt->clen].insn = OP_PUSHNONE;
cxt->clen++; cxt->clen++;
return; return;
} }
else if (type == state->sCREF) { else if (type == pic->sCREF) {
pic_sym name; pic_sym *name;
int depth; int depth;
depth = pic_int(pic_list_ref(pic, var, 1)); depth = pic_int(pic_list_ref(pic, var, 1));
name = pic_sym(pic_list_ref(pic, var, 2)); name = pic_sym_ptr(pic_list_ref(pic, var, 2));
cxt->code[cxt->clen].insn = OP_CSET; cxt->code[cxt->clen].insn = OP_CSET;
cxt->code[cxt->clen].u.r.depth = depth; cxt->code[cxt->clen].u.r.depth = depth;
cxt->code[cxt->clen].u.r.idx = index_capture(state, name, depth); cxt->code[cxt->clen].u.r.idx = index_capture(state, name, depth);
@ -1176,11 +1183,11 @@ codegen(codegen_state *state, pic_value obj)
cxt->clen++; cxt->clen++;
return; return;
} }
else if (type == state->sLREF) { else if (type == pic->sLREF) {
pic_sym name; pic_sym *name;
int i; int i;
name = pic_sym(pic_list_ref(pic, var, 1)); name = pic_sym_ptr(pic_list_ref(pic, var, 1));
if ((i = index_capture(state, name, 0)) != -1) { if ((i = index_capture(state, name, 0)) != -1) {
cxt->code[cxt->clen].insn = OP_LSET; cxt->code[cxt->clen].insn = OP_LSET;
cxt->code[cxt->clen].u.i = i + (int)xv_size(&cxt->args) + (int)xv_size(&cxt->locals) + 1; cxt->code[cxt->clen].u.i = i + (int)xv_size(&cxt->args) + (int)xv_size(&cxt->locals) + 1;
@ -1310,15 +1317,15 @@ codegen(codegen_state *state, pic_value obj)
cxt->clen++; cxt->clen++;
return; return;
} }
else if (sym == pic->sSYMBOL_P) { else if (sym == pic->sSYMBOLP) {
codegen(state, pic_list_ref(pic, obj, 1)); codegen(state, pic_list_ref(pic, obj, 1));
cxt->code[cxt->clen].insn = OP_SYMBOL_P; cxt->code[cxt->clen].insn = OP_SYMBOLP;
cxt->clen++; cxt->clen++;
return; return;
} }
else if (sym == pic->sPAIR_P) { else if (sym == pic->sPAIRP) {
codegen(state, pic_list_ref(pic, obj, 1)); codegen(state, pic_list_ref(pic, obj, 1));
cxt->code[cxt->clen].insn = OP_PAIR_P; cxt->code[cxt->clen].insn = OP_PAIRP;
cxt->clen++; cxt->clen++;
return; return;
} }
@ -1397,19 +1404,19 @@ codegen(codegen_state *state, pic_value obj)
cxt->clen++; cxt->clen++;
return; return;
} }
else if (sym == state->sCALL || sym == state->sTAILCALL) { else if (sym == pic->sCALL || sym == pic->sTAILCALL) {
int len = (int)pic_length(pic, obj); int len = (int)pic_length(pic, obj);
pic_value elt; pic_value elt;
pic_for_each (elt, pic_cdr(pic, obj)) { pic_for_each (elt, pic_cdr(pic, obj)) {
codegen(state, elt); codegen(state, elt);
} }
cxt->code[cxt->clen].insn = (sym == state->sCALL) ? OP_CALL : OP_TAILCALL; cxt->code[cxt->clen].insn = (sym == pic->sCALL) ? OP_CALL : OP_TAILCALL;
cxt->code[cxt->clen].u.i = len - 1; cxt->code[cxt->clen].u.i = len - 1;
cxt->clen++; cxt->clen++;
return; return;
} }
else if (sym == state->sCALL_WITH_VALUES || sym == state->sTAILCALL_WITH_VALUES) { else if (sym == pic->sCALL_WITH_VALUES || sym == pic->sTAILCALL_WITH_VALUES) {
/* stack consumer at first */ /* stack consumer at first */
codegen(state, pic_list_ref(pic, obj, 2)); codegen(state, pic_list_ref(pic, obj, 2));
codegen(state, pic_list_ref(pic, obj, 1)); codegen(state, pic_list_ref(pic, obj, 1));
@ -1418,12 +1425,12 @@ codegen(codegen_state *state, pic_value obj)
cxt->code[cxt->clen].u.i = 1; cxt->code[cxt->clen].u.i = 1;
cxt->clen++; cxt->clen++;
/* call consumer */ /* call consumer */
cxt->code[cxt->clen].insn = (sym == state->sCALL_WITH_VALUES) ? OP_CALL : OP_TAILCALL; cxt->code[cxt->clen].insn = (sym == pic->sCALL_WITH_VALUES) ? OP_CALL : OP_TAILCALL;
cxt->code[cxt->clen].u.i = -1; cxt->code[cxt->clen].u.i = -1;
cxt->clen++; cxt->clen++;
return; return;
} }
else if (sym == state->sRETURN) { else if (sym == pic->sRETURN) {
int len = (int)pic_length(pic, obj); int len = (int)pic_length(pic, obj);
pic_value elt; pic_value elt;
@ -1435,7 +1442,7 @@ codegen(codegen_state *state, pic_value obj)
cxt->clen++; cxt->clen++;
return; return;
} }
pic_errorf(pic, "codegen: unknown AST type"); pic_errorf(pic, "codegen: unknown AST type ~s", obj);
} }
static struct pic_irep * static struct pic_irep *

2
extlib/benz/debug.c
View File

@ -50,7 +50,7 @@ pic_print_backtrace(pic_state *pic)
e = pic_error_ptr(pic->err); e = pic_error_ptr(pic->err);
if (e->type != pic_intern_cstr(pic, "")) { if (e->type != pic_intern_cstr(pic, "")) {
trace = pic_format(pic, "~s ", pic_sym_value(e->type)); trace = pic_format(pic, "~s ", pic_obj_value(e->type));
} else { } else {
trace = pic_make_str(pic, NULL, 0); trace = pic_make_str(pic, NULL, 0);
} }

45
extlib/benz/dict.c
View File

@ -7,6 +7,7 @@
#include "picrin/cont.h" #include "picrin/cont.h"
#include "picrin/pair.h" #include "picrin/pair.h"
#include "picrin/error.h" #include "picrin/error.h"
#include "picrin/symbol.h"
struct pic_dict * struct pic_dict *
pic_make_dict(pic_state *pic) pic_make_dict(pic_state *pic)
@ -14,29 +15,29 @@ pic_make_dict(pic_state *pic)
struct pic_dict *dict; struct pic_dict *dict;
dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT); dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT);
xh_init_int(&dict->hash, sizeof(pic_value)); xh_init_ptr(&dict->hash, sizeof(pic_value));
return dict; return dict;
} }
pic_value pic_value
pic_dict_ref(pic_state *pic, struct pic_dict *dict, pic_sym key) pic_dict_ref(pic_state *pic, struct pic_dict *dict, pic_sym *key)
{ {
xh_entry *e; xh_entry *e;
e = xh_get_int(&dict->hash, key); e = xh_get_ptr(&dict->hash, key);
if (! e) { if (! e) {
pic_errorf(pic, "element not found for a key: ~s", pic_sym_value(key)); pic_errorf(pic, "element not found for a key: ~s", pic_obj_value(key));
} }
return xh_val(e, pic_value); return xh_val(e, pic_value);
} }
void void
pic_dict_set(pic_state *pic, struct pic_dict *dict, pic_sym key, pic_value val) pic_dict_set(pic_state *pic, struct pic_dict *dict, pic_sym *key, pic_value val)
{ {
PIC_UNUSED(pic); PIC_UNUSED(pic);
xh_put_int(&dict->hash, key, &val); xh_put_ptr(&dict->hash, key, &val);
} }
size_t size_t
@ -48,21 +49,21 @@ pic_dict_size(pic_state *pic, struct pic_dict *dict)
} }
bool bool
pic_dict_has(pic_state *pic, struct pic_dict *dict, pic_sym key) pic_dict_has(pic_state *pic, struct pic_dict *dict, pic_sym *key)
{ {
PIC_UNUSED(pic); PIC_UNUSED(pic);
return xh_get_int(&dict->hash, key) != NULL; return xh_get_ptr(&dict->hash, key) != NULL;
} }
void void
pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym key) pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym *key)
{ {
if (xh_get_int(&dict->hash, key) == NULL) { if (xh_get_ptr(&dict->hash, key) == NULL) {
pic_errorf(pic, "no slot named ~s found in dictionary", pic_sym_value(key)); pic_errorf(pic, "no slot named ~s found in dictionary", pic_obj_value(key));
} }
xh_del_int(&dict->hash, key); xh_del_ptr(&dict->hash, key);
} }
static pic_value static pic_value
@ -90,7 +91,7 @@ pic_dict_dictionary(pic_state *pic)
for (i = 0; i < argc; i += 2) { for (i = 0; i < argc; i += 2) {
pic_assert_type(pic, argv[i], sym); pic_assert_type(pic, argv[i], sym);
pic_dict_set(pic, dict, pic_sym(argv[i]), argv[i+1]); pic_dict_set(pic, dict, pic_sym_ptr(argv[i]), argv[i+1]);
} }
return pic_obj_value(dict); return pic_obj_value(dict);
@ -110,7 +111,7 @@ static pic_value
pic_dict_dictionary_ref(pic_state *pic) pic_dict_dictionary_ref(pic_state *pic)
{ {
struct pic_dict *dict; struct pic_dict *dict;
pic_sym key; pic_sym *key;
pic_get_args(pic, "dm", &dict, &key); pic_get_args(pic, "dm", &dict, &key);
@ -125,7 +126,7 @@ static pic_value
pic_dict_dictionary_set(pic_state *pic) pic_dict_dictionary_set(pic_state *pic)
{ {
struct pic_dict *dict; struct pic_dict *dict;
pic_sym key; pic_sym *key;
pic_value val; pic_value val;
pic_get_args(pic, "dmo", &dict, &key, &val); pic_get_args(pic, "dmo", &dict, &key, &val);
@ -139,7 +140,7 @@ static pic_value
pic_dict_dictionary_del(pic_state *pic) pic_dict_dictionary_del(pic_state *pic)
{ {
struct pic_dict *dict; struct pic_dict *dict;
pic_sym key; pic_sym *key;
pic_get_args(pic, "dm", &dict, &key); pic_get_args(pic, "dm", &dict, &key);
@ -186,7 +187,7 @@ pic_dict_dictionary_map(pic_state *pic)
if (it[i] == NULL) { if (it[i] == NULL) {
break; break;
} }
pic_push(pic, pic_sym_value(xh_key(it[i], pic_sym)), arg); pic_push(pic, pic_obj_value(xh_key(it[i], pic_sym *)), arg);
it[i] = xh_next(it[i]); it[i] = xh_next(it[i]);
} }
if (i != argc) { if (i != argc) {
@ -232,7 +233,7 @@ pic_dict_dictionary_for_each(pic_state *pic)
if (it[i] == NULL) { if (it[i] == NULL) {
break; break;
} }
pic_push(pic, pic_sym_value(xh_key(it[i], pic_sym)), arg); pic_push(pic, pic_obj_value(xh_key(it[i], pic_sym *)), arg);
it[i] = xh_next(it[i]); it[i] = xh_next(it[i]);
} }
if (i != argc) { if (i != argc) {
@ -261,7 +262,7 @@ pic_dict_dictionary_to_alist(pic_state *pic)
pic_get_args(pic, "d", &dict); pic_get_args(pic, "d", &dict);
for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) { for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) {
item = pic_cons(pic, pic_sym_value(xh_key(it, pic_sym)), xh_val(it, pic_value)); item = pic_cons(pic, pic_obj_value(xh_key(it, pic_sym *)), xh_val(it, pic_value));
pic_push(pic, item, alist); pic_push(pic, item, alist);
} }
@ -280,7 +281,7 @@ pic_dict_alist_to_dictionary(pic_state *pic)
pic_for_each (e, pic_reverse(pic, alist)) { pic_for_each (e, pic_reverse(pic, alist)) {
pic_assert_type(pic, pic_car(pic, e), sym); pic_assert_type(pic, pic_car(pic, e), sym);
pic_dict_set(pic, dict, pic_sym(pic_car(pic, e)), pic_cdr(pic, e)); pic_dict_set(pic, dict, pic_sym_ptr(pic_car(pic, e)), pic_cdr(pic, e));
} }
return pic_obj_value(dict); return pic_obj_value(dict);
@ -296,7 +297,7 @@ pic_dict_dictionary_to_plist(pic_state *pic)
pic_get_args(pic, "d", &dict); pic_get_args(pic, "d", &dict);
for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) { for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) {
pic_push(pic, pic_sym_value(xh_key(it, pic_sym)), plist); pic_push(pic, pic_obj_value(xh_key(it, pic_sym *)), plist);
pic_push(pic, xh_val(it, pic_value), plist); pic_push(pic, xh_val(it, pic_value), plist);
} }
@ -315,7 +316,7 @@ pic_dict_plist_to_dictionary(pic_state *pic)
for (e = pic_reverse(pic, plist); ! pic_nil_p(e); e = pic_cddr(pic, e)) { for (e = pic_reverse(pic, plist); ! pic_nil_p(e); e = pic_cddr(pic, e)) {
pic_assert_type(pic, pic_cadr(pic, e), sym); pic_assert_type(pic, pic_cadr(pic, e), sym);
pic_dict_set(pic, dict, pic_sym(pic_cadr(pic, e)), pic_car(pic, e)); pic_dict_set(pic, dict, pic_sym_ptr(pic_cadr(pic, e)), pic_car(pic, e));
} }
return pic_obj_value(dict); return pic_obj_value(dict);

8
extlib/benz/error.c
View File

@ -125,7 +125,7 @@ pic_pop_try(pic_state *pic)
} }
struct pic_error * struct pic_error *
pic_make_error(pic_state *pic, pic_sym type, const char *msg, pic_value irrs) pic_make_error(pic_state *pic, pic_sym *type, const char *msg, pic_value irrs)
{ {
struct pic_error *e; struct pic_error *e;
pic_str *stack; pic_str *stack;
@ -175,7 +175,7 @@ pic_raise(pic_state *pic, pic_value err)
} }
void void
pic_throw(pic_state *pic, pic_sym type, const char *msg, pic_value irrs) pic_throw(pic_state *pic, pic_sym *type, const char *msg, pic_value irrs)
{ {
struct pic_error *e; struct pic_error *e;
@ -253,7 +253,7 @@ static pic_value
pic_error_make_error_object(pic_state *pic) pic_error_make_error_object(pic_state *pic)
{ {
struct pic_error *e; struct pic_error *e;
pic_sym type; pic_sym *type;
pic_str *msg; pic_str *msg;
size_t argc; size_t argc;
pic_value *argv; pic_value *argv;
@ -302,7 +302,7 @@ pic_error_error_object_type(pic_state *pic)
pic_get_args(pic, "e", &e); pic_get_args(pic, "e", &e);
return pic_sym_value(e->type); return pic_obj_value(e->type);
} }
void void

68
extlib/benz/gc.c
View File

@ -19,6 +19,7 @@
#include "picrin/dict.h" #include "picrin/dict.h"
#include "picrin/record.h" #include "picrin/record.h"
#include "picrin/read.h" #include "picrin/read.h"
#include "picrin/symbol.h"
union header { union header {
struct { struct {
@ -389,6 +390,8 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
} }
if (pic_proc_irep_p(proc)) { if (pic_proc_irep_p(proc)) {
gc_mark_object(pic, (struct pic_object *)proc->u.irep); gc_mark_object(pic, (struct pic_object *)proc->u.irep);
} else {
gc_mark_object(pic, (struct pic_object *)proc->u.func.name);
} }
break; break;
} }
@ -397,7 +400,8 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
} }
case PIC_TT_ERROR: { case PIC_TT_ERROR: {
struct pic_error *err = (struct pic_error *)obj; struct pic_error *err = (struct pic_error *)obj;
gc_mark_object(pic,(struct pic_object *)err->msg); gc_mark_object(pic, (struct pic_object *)err->type);
gc_mark_object(pic, (struct pic_object *)err->msg);
gc_mark(pic, err->irrs); gc_mark(pic, err->irrs);
gc_mark_object(pic, (struct pic_object *)err->stack); gc_mark_object(pic, (struct pic_object *)err->stack);
break; break;
@ -422,24 +426,31 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
gc_mark_object(pic, (struct pic_object *)senv->up); gc_mark_object(pic, (struct pic_object *)senv->up);
} }
gc_mark(pic, senv->defer); gc_mark(pic, senv->defer);
gc_mark_object(pic, (struct pic_object *)senv->map);
break; break;
} }
case PIC_TT_LIB: { case PIC_TT_LIB: {
struct pic_lib *lib = (struct pic_lib *)obj; struct pic_lib *lib = (struct pic_lib *)obj;
gc_mark(pic, lib->name); gc_mark(pic, lib->name);
gc_mark_object(pic, (struct pic_object *)lib->env); gc_mark_object(pic, (struct pic_object *)lib->env);
gc_mark_object(pic, (struct pic_object *)lib->exports);
break; break;
} }
case PIC_TT_IREP: { case PIC_TT_IREP: {
struct pic_irep *irep = (struct pic_irep *)obj; struct pic_irep *irep = (struct pic_irep *)obj;
size_t i; size_t i;
gc_mark_object(pic, (struct pic_object *)irep->name);
for (i = 0; i < irep->ilen; ++i) { for (i = 0; i < irep->ilen; ++i) {
gc_mark_object(pic, (struct pic_object *)irep->irep[i]); gc_mark_object(pic, (struct pic_object *)irep->irep[i]);
} }
for (i = 0; i < irep->plen; ++i) { for (i = 0; i < irep->plen; ++i) {
gc_mark(pic, irep->pool[i]); gc_mark(pic, irep->pool[i]);
} }
for (i = 0; i < irep->slen; ++i) {
gc_mark_object(pic, (struct pic_object *)irep->syms[i]);
}
break; break;
} }
case PIC_TT_DATA: { case PIC_TT_DATA: {
@ -459,24 +470,27 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
xh_entry *it; xh_entry *it;
for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) { for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) {
gc_mark_object(pic, (struct pic_object *)xh_key(it, pic_sym *));
gc_mark(pic, xh_val(it, pic_value)); gc_mark(pic, xh_val(it, pic_value));
} }
break; break;
} }
case PIC_TT_RECORD: { case PIC_TT_RECORD: {
struct pic_record *rec = (struct pic_record *)obj; struct pic_record *rec = (struct pic_record *)obj;
xh_entry *it;
for (it = xh_begin(&rec->hash); it != NULL; it = xh_next(it)) { gc_mark_object(pic, (struct pic_object *)rec->data);
gc_mark(pic, xh_val(it, pic_value)); break;
} }
case PIC_TT_SYMBOL: {
struct pic_symbol *sym = (struct pic_symbol *)obj;
gc_mark_object(pic, (struct pic_object *)sym->str);
break; break;
} }
case PIC_TT_NIL: case PIC_TT_NIL:
case PIC_TT_BOOL: case PIC_TT_BOOL:
case PIC_TT_FLOAT: case PIC_TT_FLOAT:
case PIC_TT_INT: case PIC_TT_INT:
case PIC_TT_SYMBOL:
case PIC_TT_CHAR: case PIC_TT_CHAR:
case PIC_TT_EOF: case PIC_TT_EOF:
case PIC_TT_UNDEF: case PIC_TT_UNDEF:
@ -511,6 +525,17 @@ gc_mark_trie(pic_state *pic, struct pic_trie *trie)
} }
} }
#define M(x) gc_mark_object(pic, (struct pic_object *)pic->x)
static void
gc_mark_global_symbols(pic_state *pic)
{
M(rDEFINE); M(rLAMBDA); M(rIF); M(rBEGIN); M(rQUOTE); M(rSETBANG);
M(rDEFINE_SYNTAX); M(rIMPORT); M(rEXPORT);
M(rDEFINE_LIBRARY); M(rIN_LIBRARY);
M(rCOND_EXPAND);
}
static void static void
gc_mark_phase(pic_state *pic) gc_mark_phase(pic_state *pic)
{ {
@ -548,14 +573,22 @@ gc_mark_phase(pic_state *pic)
gc_mark_object(pic, pic->arena[j]); gc_mark_object(pic, pic->arena[j]);
} }
/* mark reserved uninterned symbols */
gc_mark_global_symbols(pic);
/* mark all interned symbols */
for (it = xh_begin(&pic->syms); it != NULL; it = xh_next(it)) {
gc_mark_object(pic, (struct pic_object *)xh_val(it, pic_sym *));
}
/* global variables */ /* global variables */
for (it = xh_begin(&pic->globals); it != NULL; it = xh_next(it)) { if (pic->globals) {
gc_mark(pic, xh_val(it, pic_value)); gc_mark_object(pic, (struct pic_object *)pic->globals);
} }
/* macro objects */ /* macro objects */
for (it = xh_begin(&pic->macros); it != NULL; it = xh_next(it)) { if (pic->macros) {
gc_mark_object(pic, xh_val(it, struct pic_object *)); gc_mark_object(pic, (struct pic_object *)pic->macros);
} }
/* error object */ /* error object */
@ -635,13 +668,9 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
break; break;
} }
case PIC_TT_SENV: { case PIC_TT_SENV: {
struct pic_senv *senv = (struct pic_senv *)obj;
xh_destroy(&senv->map);
break; break;
} }
case PIC_TT_LIB: { case PIC_TT_LIB: {
struct pic_lib *lib = (struct pic_lib *)obj;
xh_destroy(&lib->exports);
break; break;
} }
case PIC_TT_IREP: { case PIC_TT_IREP: {
@ -649,6 +678,7 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
pic_free(pic, irep->code); pic_free(pic, irep->code);
pic_free(pic, irep->irep); pic_free(pic, irep->irep);
pic_free(pic, irep->pool); pic_free(pic, irep->pool);
pic_free(pic, irep->syms);
break; break;
} }
case PIC_TT_DATA: { case PIC_TT_DATA: {
@ -663,15 +693,15 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
break; break;
} }
case PIC_TT_RECORD: { case PIC_TT_RECORD: {
struct pic_record *rec = (struct pic_record *)obj; break;
xh_destroy(&rec->hash); }
case PIC_TT_SYMBOL: {
break; break;
} }
case PIC_TT_NIL: case PIC_TT_NIL:
case PIC_TT_BOOL: case PIC_TT_BOOL:
case PIC_TT_FLOAT: case PIC_TT_FLOAT:
case PIC_TT_INT: case PIC_TT_INT:
case PIC_TT_SYMBOL:
case PIC_TT_CHAR: case PIC_TT_CHAR:
case PIC_TT_EOF: case PIC_TT_EOF:
case PIC_TT_UNDEF: case PIC_TT_UNDEF:
@ -758,6 +788,10 @@ pic_gc_run(pic_state *pic)
struct heap_page *page; struct heap_page *page;
#endif #endif
if (! pic->gc_enable) {
return;
}
#if DEBUG #if DEBUG
puts("gc run!"); puts("gc run!");
#endif #endif

56
extlib/benz/include/picrin.h
View File

@ -89,22 +89,25 @@ typedef struct {
struct pic_lib *lib; struct pic_lib *lib;
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, sIMPORT, sEXPORT; pic_sym *sDEFINE_SYNTAX, *sIMPORT, *sEXPORT;
pic_sym sDEFINE_LIBRARY, sIN_LIBRARY; pic_sym *sDEFINE_LIBRARY, *sIN_LIBRARY;
pic_sym sCOND_EXPAND, sAND, sOR, sELSE, sLIBRARY; pic_sym *sCOND_EXPAND, *sAND, *sOR, *sELSE, *sLIBRARY;
pic_sym sONLY, sRENAME, sPREFIX, sEXCEPT; pic_sym *sONLY, *sRENAME, *sPREFIX, *sEXCEPT;
pic_sym sCONS, sCAR, sCDR, sNILP; pic_sym *sCONS, *sCAR, *sCDR, *sNILP;
pic_sym sSYMBOL_P, sPAIR_P; pic_sym *sSYMBOLP, *sPAIRP;
pic_sym sADD, sSUB, sMUL, sDIV, sMINUS; pic_sym *sADD, *sSUB, *sMUL, *sDIV, *sMINUS;
pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT; pic_sym *sEQ, *sLT, *sLE, *sGT, *sGE, *sNOT;
pic_sym sREAD, sFILE; pic_sym *sREAD, *sFILE;
pic_sym *sGREF, *sCREF, *sLREF;
pic_sym *sCALL, *sTAILCALL, *sRETURN;
pic_sym *sCALL_WITH_VALUES, *sTAILCALL_WITH_VALUES;
pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG; pic_sym *rDEFINE, *rLAMBDA, *rIF, *rBEGIN, *rQUOTE, *rSETBANG;
pic_sym rDEFINE_SYNTAX, rIMPORT, rEXPORT; pic_sym *rDEFINE_SYNTAX, *rIMPORT, *rEXPORT;
pic_sym rDEFINE_LIBRARY, rIN_LIBRARY; pic_sym *rDEFINE_LIBRARY, *rIN_LIBRARY;
pic_sym rCOND_EXPAND; pic_sym *rCOND_EXPAND;
struct pic_lib *PICRIN_BASE; struct pic_lib *PICRIN_BASE;
struct pic_lib *PICRIN_USER; struct pic_lib *PICRIN_USER;
@ -112,17 +115,14 @@ typedef struct {
pic_value features; pic_value features;
xhash syms; /* name to symbol */ xhash syms; /* name to symbol */
xhash sym_names; /* symbol to name */ struct pic_dict *globals;
int sym_cnt; struct pic_dict *macros;
int uniq_sym_cnt;
xhash globals;
xhash macros;
pic_value libs; pic_value libs;
xhash attrs; xhash attrs;
struct pic_reader *reader; struct pic_reader *reader;
bool gc_enable;
struct pic_heap *heap; struct pic_heap *heap;
struct pic_object **arena; struct pic_object **arena;
size_t arena_size, arena_idx; size_t arena_size, arena_idx;
@ -175,13 +175,11 @@ bool pic_eq_p(pic_value, pic_value);
bool pic_eqv_p(pic_value, pic_value); bool pic_eqv_p(pic_value, pic_value);
bool pic_equal_p(pic_state *, pic_value, pic_value); bool pic_equal_p(pic_state *, pic_value, pic_value);
pic_sym pic_intern(pic_state *, const char *, size_t); pic_sym *pic_intern(pic_state *, pic_str *);
pic_sym pic_intern_str(pic_state *, pic_str *); pic_sym *pic_intern_cstr(pic_state *, const char *);
pic_sym pic_intern_cstr(pic_state *, const char *); const char *pic_symbol_name(pic_state *, pic_sym *);
const char *pic_symbol_name(pic_state *, pic_sym); pic_sym *pic_gensym(pic_state *, pic_sym *);
pic_sym pic_gensym(pic_state *, pic_sym); bool pic_interned_p(pic_state *, pic_sym *);
pic_sym pic_ungensym(pic_state *, pic_sym);
bool pic_interned_p(pic_state *, pic_sym);
pic_value pic_read(pic_state *, struct pic_port *); pic_value pic_read(pic_state *, struct pic_port *);
pic_value pic_read_cstr(pic_state *, const char *); pic_value pic_read_cstr(pic_state *, const char *);
@ -218,7 +216,7 @@ struct pic_lib *pic_find_library(pic_state *, pic_value);
void pic_import(pic_state *, pic_value); void pic_import(pic_state *, pic_value);
void pic_import_library(pic_state *, struct pic_lib *); void pic_import_library(pic_state *, struct pic_lib *);
void pic_export(pic_state *, pic_sym); void pic_export(pic_state *, pic_sym *);
pic_noreturn void pic_panic(pic_state *, const char *); pic_noreturn void pic_panic(pic_state *, const char *);
pic_noreturn void pic_errorf(pic_state *, const char *, ...); pic_noreturn void pic_errorf(pic_state *, const char *, ...);

15
extlib/benz/include/picrin/dict.h
View File

@ -19,11 +19,18 @@ struct pic_dict {
struct pic_dict *pic_make_dict(pic_state *); struct pic_dict *pic_make_dict(pic_state *);
pic_value pic_dict_ref(pic_state *, struct pic_dict *, pic_sym); #define pic_dict_for_each(sym, dict) \
void pic_dict_set(pic_state *, struct pic_dict *, pic_sym, pic_value); pic_dict_for_each_helper_((sym), PIC_GENSYM(tmp), (dict))
void pic_dict_del(pic_state *, struct pic_dict *, pic_sym); #define pic_dict_for_each_helper_(var, tmp, dict) \
for (xh_entry *tmp = xh_begin(&dict->hash); \
(tmp && ((var = xh_key(tmp, pic_sym *)), 1)); \
tmp = xh_next(tmp))
pic_value pic_dict_ref(pic_state *, struct pic_dict *, pic_sym *);
void pic_dict_set(pic_state *, struct pic_dict *, pic_sym *, pic_value);
void pic_dict_del(pic_state *, struct pic_dict *, pic_sym *);
size_t pic_dict_size(pic_state *, struct pic_dict *); size_t pic_dict_size(pic_state *, struct pic_dict *);
bool pic_dict_has(pic_state *, struct pic_dict *, pic_sym); bool pic_dict_has(pic_state *, struct pic_dict *, pic_sym *);
#if defined(__cplusplus) #if defined(__cplusplus)
} }

6
extlib/benz/include/picrin/error.h
View File

@ -13,7 +13,7 @@ extern "C" {
struct pic_error { struct pic_error {
PIC_OBJECT_HEADER PIC_OBJECT_HEADER
pic_sym type; pic_sym *type;
pic_str *msg; pic_str *msg;
pic_value irrs; pic_value irrs;
pic_str *stack; pic_str *stack;
@ -22,7 +22,7 @@ struct pic_error {
#define pic_error_p(v) (pic_type(v) == PIC_TT_ERROR) #define pic_error_p(v) (pic_type(v) == PIC_TT_ERROR)
#define pic_error_ptr(v) ((struct pic_error *)pic_ptr(v)) #define pic_error_ptr(v) ((struct pic_error *)pic_ptr(v))
struct pic_error *pic_make_error(pic_state *, pic_sym, const char *, pic_list); struct pic_error *pic_make_error(pic_state *, pic_sym *, const char *, pic_list);
/* do not return from try block! */ /* do not return from try block! */
@ -44,7 +44,7 @@ void pic_pop_try(pic_state *);
pic_value pic_raise_continuable(pic_state *, pic_value); pic_value pic_raise_continuable(pic_state *, pic_value);
pic_noreturn void pic_raise(pic_state *, pic_value); pic_noreturn void pic_raise(pic_state *, pic_value);
pic_noreturn void pic_throw(pic_state *, pic_sym, const char *, pic_list); pic_noreturn void pic_throw(pic_state *, pic_sym *, const char *, pic_list);
pic_noreturn void pic_error(pic_state *, const char *, pic_list); pic_noreturn void pic_error(pic_state *, const char *, pic_list);
#if defined(__cplusplus) #if defined(__cplusplus)

17
extlib/benz/include/picrin/irep.h
View File

@ -35,8 +35,8 @@ enum pic_opcode {
OP_CAR, OP_CAR,
OP_CDR, OP_CDR,
OP_NILP, OP_NILP,
OP_SYMBOL_P, OP_SYMBOLP,
OP_PAIR_P, OP_PAIRP,
OP_ADD, OP_ADD,
OP_SUB, OP_SUB,
OP_MUL, OP_MUL,
@ -62,13 +62,14 @@ struct pic_code {
struct pic_irep { struct pic_irep {
PIC_OBJECT_HEADER PIC_OBJECT_HEADER
pic_sym name; pic_sym *name;
pic_code *code; pic_code *code;
int argc, localc, capturec; int argc, localc, capturec;
bool varg; bool varg;
struct pic_irep **irep; struct pic_irep **irep;
pic_value *pool; pic_value *pool;
size_t clen, ilen, plen; pic_sym **syms;
size_t clen, ilen, plen, slen;
}; };
pic_value pic_analyze(pic_state *, pic_value); pic_value pic_analyze(pic_state *, pic_value);
@ -151,11 +152,11 @@ pic_dump_code(pic_code c)
case OP_NILP: case OP_NILP:
puts("OP_NILP"); puts("OP_NILP");
break; break;
case OP_SYMBOL_P: case OP_SYMBOLP:
puts("OP_SYMBOL_P"); puts("OP_SYMBOLP");
break; break;
case OP_PAIR_P: case OP_PAIRP:
puts("OP_PAIR_P"); puts("OP_PAIRP");
break; break;
case OP_CDR: case OP_CDR:
puts("OP_CDR"); puts("OP_CDR");

2
extlib/benz/include/picrin/lib.h
View File

@ -13,7 +13,7 @@ struct pic_lib {
PIC_OBJECT_HEADER PIC_OBJECT_HEADER
pic_value name; pic_value name;
struct pic_senv *env; struct pic_senv *env;
xhash exports; struct pic_dict *exports;
}; };
#define pic_lib_ptr(o) ((struct pic_lib *)pic_ptr(o)) #define pic_lib_ptr(o) ((struct pic_lib *)pic_ptr(o))

12
extlib/benz/include/picrin/macro.h
View File

@ -11,7 +11,7 @@ extern "C" {
struct pic_senv { struct pic_senv {
PIC_OBJECT_HEADER PIC_OBJECT_HEADER
xhash map; struct pic_dict *map;
pic_value defer; pic_value defer;
struct pic_senv *up; struct pic_senv *up;
}; };
@ -22,15 +22,15 @@ struct pic_senv {
struct pic_senv *pic_null_syntactic_environment(pic_state *); struct pic_senv *pic_null_syntactic_environment(pic_state *);
bool pic_identifier_p(pic_state *pic, pic_value obj); bool pic_identifier_p(pic_state *pic, pic_value obj);
bool pic_identifier_eq_p(pic_state *, struct pic_senv *, pic_sym, struct pic_senv *, pic_sym); bool pic_identifier_eq_p(pic_state *, struct pic_senv *, pic_sym *, struct pic_senv *, pic_sym *);
struct pic_senv *pic_make_senv(pic_state *, struct pic_senv *); struct pic_senv *pic_make_senv(pic_state *, struct pic_senv *);
pic_sym pic_add_rename(pic_state *, struct pic_senv *, pic_sym); pic_sym *pic_add_rename(pic_state *, struct pic_senv *, pic_sym *);
bool pic_find_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym * /* = NULL */); bool pic_find_rename(pic_state *, struct pic_senv *, pic_sym *, pic_sym ** /* = NULL */);
void pic_put_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym); void pic_put_rename(pic_state *, struct pic_senv *, pic_sym *, pic_sym *);
void pic_define_syntactic_keyword(pic_state *, struct pic_senv *, pic_sym, pic_sym); void pic_define_syntactic_keyword(pic_state *, struct pic_senv *, pic_sym *, pic_sym *);
#if defined(__cplusplus) #if defined(__cplusplus)
} }

4
extlib/benz/include/picrin/proc.h
View File

@ -12,7 +12,7 @@ extern "C" {
/* native C function */ /* native C function */
struct pic_func { struct pic_func {
pic_func_t f; pic_func_t f;
pic_sym name; pic_sym *name;
}; };
struct pic_env { struct pic_env {
@ -48,7 +48,7 @@ struct pic_proc {
struct pic_proc *pic_make_proc(pic_state *, pic_func_t, const char *); struct pic_proc *pic_make_proc(pic_state *, pic_func_t, const char *);
struct pic_proc *pic_make_proc_irep(pic_state *, struct pic_irep *, struct pic_env *); struct pic_proc *pic_make_proc_irep(pic_state *, struct pic_irep *, struct pic_env *);
pic_sym pic_proc_name(struct pic_proc *); pic_sym *pic_proc_name(struct pic_proc *);
#if defined(__cplusplus) #if defined(__cplusplus)
} }

6
extlib/benz/include/picrin/record.h
View File

@ -11,7 +11,7 @@ extern "C" {
struct pic_record { struct pic_record {
PIC_OBJECT_HEADER PIC_OBJECT_HEADER
xhash hash; struct pic_dict *data;
}; };
#define pic_record_p(v) (pic_type(v) == PIC_TT_RECORD) #define pic_record_p(v) (pic_type(v) == PIC_TT_RECORD)
@ -20,8 +20,8 @@ struct pic_record {
struct pic_record *pic_make_record(pic_state *, pic_value); struct pic_record *pic_make_record(pic_state *, pic_value);
pic_value pic_record_type(pic_state *, struct pic_record *); pic_value pic_record_type(pic_state *, struct pic_record *);
pic_value pic_record_ref(pic_state *, struct pic_record *, pic_sym); pic_value pic_record_ref(pic_state *, struct pic_record *, pic_sym *);
void pic_record_set(pic_state *, struct pic_record *, pic_sym, pic_value); void pic_record_set(pic_state *, struct pic_record *, pic_sym *, pic_value);
#if defined(__cplusplus) #if defined(__cplusplus)
} }

24
extlib/benz/include/picrin/symbol.h Normal file
View File

@ -0,0 +1,24 @@
/**
* See Copyright Notice in picrin.h
*/
#ifndef PICRIN_SYMBOL_H
#define PICRIN_SYMBOL_H
#if defined(__cplusplus)
extern "C" {
#endif
struct pic_symbol {
PIC_OBJECT_HEADER
pic_str *str;
};
#define pic_sym_p(v) (pic_type(v) == PIC_TT_SYMBOL)
#define pic_sym_ptr(v) ((struct pic_symbol *)pic_ptr(v))
#if defined(__cplusplus)
}
#endif
#endif

55
extlib/benz/include/picrin/value.h
View File

@ -9,12 +9,6 @@
extern "C" { extern "C" {
#endif #endif
/**
* pic_sym is just an alias of int.
*/
typedef int pic_sym;
/** /**
* `undef` values never seen from user-end: that is, * `undef` values never seen from user-end: that is,
* it's used only for repsenting internal special state * it's used only for repsenting internal special state
@ -27,7 +21,6 @@ enum pic_vtype {
PIC_VTYPE_UNDEF, PIC_VTYPE_UNDEF,
PIC_VTYPE_FLOAT, PIC_VTYPE_FLOAT,
PIC_VTYPE_INT, PIC_VTYPE_INT,
PIC_VTYPE_SYMBOL,
PIC_VTYPE_CHAR, PIC_VTYPE_CHAR,
PIC_VTYPE_EOF, PIC_VTYPE_EOF,
PIC_VTYPE_HEAP PIC_VTYPE_HEAP
@ -40,7 +33,6 @@ enum pic_vtype {
* float : FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF * float : FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF
* ptr : 111111111111TTTT PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP * ptr : 111111111111TTTT PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP
* int : 1111111111110110 0000000000000000 IIIIIIIIIIIIIIII IIIIIIIIIIIIIIII * int : 1111111111110110 0000000000000000 IIIIIIIIIIIIIIII IIIIIIIIIIIIIIII
* sym : 1111111111110111 0000000000000000 SSSSSSSSSSSSSSSS SSSSSSSSSSSSSSSS
* char : 1111111111111000 0000000000000000 CCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCC * char : 1111111111111000 0000000000000000 CCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCC
*/ */
@ -71,14 +63,6 @@ pic_int(pic_value v)
return u.i; return u.i;
} }
static inline int
pic_sym(pic_value v)
{
union { int i; unsigned u; } u;
u.u = v & 0xfffffffful;
return u.i;
}
#define pic_char(v) ((v) & 0xfffffffful) #define pic_char(v) ((v) & 0xfffffffful)
#else #else
@ -89,7 +73,6 @@ typedef struct {
void *data; void *data;
double f; double f;
int i; int i;
pic_sym sym;
char c; char c;
} u; } u;
} pic_value; } pic_value;
@ -100,7 +83,6 @@ typedef struct {
#define pic_float(v) ((v).u.f) #define pic_float(v) ((v).u.f)
#define pic_int(v) ((v).u.i) #define pic_int(v) ((v).u.i)
#define pic_sym(v) ((v).u.sym)
#define pic_char(v) ((v).u.c) #define pic_char(v) ((v).u.c)
#endif #endif
@ -111,11 +93,11 @@ enum pic_tt {
PIC_TT_BOOL, PIC_TT_BOOL,
PIC_TT_FLOAT, PIC_TT_FLOAT,
PIC_TT_INT, PIC_TT_INT,
PIC_TT_SYMBOL,
PIC_TT_CHAR, PIC_TT_CHAR,
PIC_TT_EOF, PIC_TT_EOF,
PIC_TT_UNDEF, PIC_TT_UNDEF,
/* heap */ /* heap */
PIC_TT_SYMBOL,
PIC_TT_PAIR, PIC_TT_PAIR,
PIC_TT_STRING, PIC_TT_STRING,
PIC_TT_VECTOR, PIC_TT_VECTOR,
@ -139,6 +121,7 @@ struct pic_object {
PIC_OBJECT_HEADER PIC_OBJECT_HEADER
}; };
struct pic_symbol;
struct pic_pair; struct pic_pair;
struct pic_string; struct pic_string;
struct pic_vector; struct pic_vector;
@ -150,6 +133,7 @@ struct pic_error;
/* set aliases to basic types */ /* set aliases to basic types */
typedef pic_value pic_list; typedef pic_value pic_list;
typedef struct pic_symbol pic_sym;
typedef struct pic_pair pic_pair; typedef struct pic_pair pic_pair;
typedef struct pic_string pic_str; typedef struct pic_string pic_str;
typedef struct pic_vector pic_vec; typedef struct pic_vector pic_vec;
@ -164,7 +148,6 @@ typedef struct pic_blob pic_blob;
#define pic_undef_p(v) (pic_vtype(v) == PIC_VTYPE_UNDEF) #define pic_undef_p(v) (pic_vtype(v) == PIC_VTYPE_UNDEF)
#define pic_float_p(v) (pic_vtype(v) == PIC_VTYPE_FLOAT) #define pic_float_p(v) (pic_vtype(v) == PIC_VTYPE_FLOAT)
#define pic_int_p(v) (pic_vtype(v) == PIC_VTYPE_INT) #define pic_int_p(v) (pic_vtype(v) == PIC_VTYPE_INT)
#define pic_sym_p(v) (pic_vtype(v) == PIC_VTYPE_SYMBOL)
#define pic_char_p(v) (pic_vtype(v) == PIC_VTYPE_CHAR) #define pic_char_p(v) (pic_vtype(v) == PIC_VTYPE_CHAR)
#define pic_eof_p(v) (pic_vtype(v) == PIC_VTYPE_EOF) #define pic_eof_p(v) (pic_vtype(v) == PIC_VTYPE_EOF)
@ -189,12 +172,9 @@ static inline pic_value pic_obj_value(void *);
static inline pic_value pic_float_value(double); static inline pic_value pic_float_value(double);
static inline pic_value pic_int_value(int); static inline pic_value pic_int_value(int);
static inline pic_value pic_size_value(size_t); static inline pic_value pic_size_value(size_t);
static inline pic_value pic_sym_value(pic_sym);
static inline pic_value pic_char_value(char c); static inline pic_value pic_char_value(char c);
static inline pic_value pic_none_value(); static inline pic_value pic_none_value();
#define pic_symbol_value(sym) pic_sym_value(sym)
static inline bool pic_eq_p(pic_value, pic_value); static inline bool pic_eq_p(pic_value, pic_value);
static inline bool pic_eqv_p(pic_value, pic_value); static inline bool pic_eqv_p(pic_value, pic_value);
@ -214,8 +194,6 @@ pic_type(pic_value v)
return PIC_TT_FLOAT; return PIC_TT_FLOAT;
case PIC_VTYPE_INT: case PIC_VTYPE_INT:
return PIC_TT_INT; return PIC_TT_INT;
case PIC_VTYPE_SYMBOL:
return PIC_TT_SYMBOL;
case PIC_VTYPE_CHAR: case PIC_VTYPE_CHAR:
return PIC_TT_CHAR; return PIC_TT_CHAR;
case PIC_VTYPE_EOF: case PIC_VTYPE_EOF:
@ -370,19 +348,6 @@ pic_int_value(int i)
return v; return v;
} }
static inline pic_value
pic_symbol_value(pic_sym sym)
{
union { int i; unsigned u; } u;
pic_value v;
u.i = sym;
pic_init_value(v, PIC_VTYPE_SYMBOL);
v |= u.u;
return v;
}
static inline pic_value static inline pic_value
pic_char_value(char c) pic_char_value(char c)
{ {
@ -425,16 +390,6 @@ pic_int_value(int i)
return v; return v;
} }
static inline pic_value
pic_symbol_value(pic_sym sym)
{
pic_value v;
pic_init_value(v, PIC_VTYPE_SYMBOL);
v.u.sym = sym;
return v;
}
static inline pic_value static inline pic_value
pic_char_value(char c) pic_char_value(char c)
{ {
@ -493,8 +448,6 @@ pic_eq_p(pic_value x, pic_value y)
return true; return true;
case PIC_TT_BOOL: case PIC_TT_BOOL:
return pic_vtype(x) == pic_vtype(y); return pic_vtype(x) == pic_vtype(y);
case PIC_TT_SYMBOL:
return pic_sym(x) == pic_sym(y);
default: default:
return pic_ptr(x) == pic_ptr(y); return pic_ptr(x) == pic_ptr(y);
} }
@ -511,8 +464,6 @@ pic_eqv_p(pic_value x, pic_value y)
return true; return true;
case PIC_TT_BOOL: case PIC_TT_BOOL:
return pic_vtype(x) == pic_vtype(y); return pic_vtype(x) == pic_vtype(y);
case PIC_TT_SYMBOL:
return pic_sym(x) == pic_sym(y);
case PIC_TT_FLOAT: case PIC_TT_FLOAT:
return pic_float(x) == pic_float(y); return pic_float(x) == pic_float(y);
case PIC_TT_INT: case PIC_TT_INT:

2
extlib/benz/init.c
View File

@ -11,7 +11,7 @@
void void
pic_add_feature(pic_state *pic, const char *feature) pic_add_feature(pic_state *pic, const char *feature)
{ {
pic_push(pic, pic_sym_value(pic_intern_cstr(pic, feature)), pic->features); pic_push(pic, pic_obj_value(pic_intern_cstr(pic, feature)), pic->features);
} }
void pic_init_bool(pic_state *); void pic_init_bool(pic_state *);

108
extlib/benz/lib.c
View File

@ -9,12 +9,15 @@
#include "picrin/error.h" #include "picrin/error.h"
#include "picrin/string.h" #include "picrin/string.h"
#include "picrin/proc.h" #include "picrin/proc.h"
#include "picrin/dict.h"
#include "picrin/symbol.h"
struct pic_lib * struct pic_lib *
pic_open_library(pic_state *pic, pic_value name) pic_open_library(pic_state *pic, pic_value name)
{ {
struct pic_lib *lib; struct pic_lib *lib;
struct pic_senv *senv; struct pic_senv *senv;
struct pic_dict *exports;
if ((lib = pic_find_library(pic, name)) != NULL) { if ((lib = pic_find_library(pic, name)) != NULL) {
@ -28,11 +31,12 @@ pic_open_library(pic_state *pic, pic_value name)
} }
senv = pic_null_syntactic_environment(pic); senv = pic_null_syntactic_environment(pic);
exports = pic_make_dict(pic);
lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB); lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB);
lib->env = senv;
lib->name = name; lib->name = name;
xh_init_int(&lib->exports, sizeof(pic_sym)); lib->env = senv;
lib->exports = exports;
/* register! */ /* register! */
pic->libs = pic_acons(pic, name, pic_obj_value(lib), pic->libs); pic->libs = pic_acons(pic, name, pic_obj_value(lib), pic->libs);
@ -65,93 +69,85 @@ pic_find_library(pic_state *pic, pic_value spec)
} }
static void static void
import_table(pic_state *pic, pic_value spec, xhash *imports) import_table(pic_state *pic, pic_value spec, struct pic_dict *imports)
{ {
struct pic_lib *lib; struct pic_lib *lib;
xhash table; struct pic_dict *table;
pic_value val; pic_value val, tmp, prefix;
pic_sym sym, id, tag; pic_sym *sym, *id, *tag;
xh_entry *it;
xh_init_int(&table, sizeof(pic_sym)); table = pic_make_dict(pic);
if (pic_pair_p(spec) && pic_sym_p(pic_car(pic, spec))) { if (pic_pair_p(spec) && pic_sym_p(pic_car(pic, spec))) {
tag = pic_sym(pic_car(pic, spec)); tag = pic_sym_ptr(pic_car(pic, spec));
if (tag == pic->sONLY) { if (tag == pic->sONLY) {
import_table(pic, pic_cadr(pic, spec), &table); import_table(pic, pic_cadr(pic, spec), table);
pic_for_each (val, pic_cddr(pic, spec)) { pic_for_each (val, pic_cddr(pic, spec)) {
xh_put_int(imports, pic_sym(val), &xh_val(xh_get_int(&table, pic_sym(val)), pic_sym)); pic_dict_set(pic, imports, pic_sym_ptr(val), pic_dict_ref(pic, table, pic_sym_ptr(val)));
} }
goto exit; return;
} }
if (tag == pic->sRENAME) { if (tag == pic->sRENAME) {
import_table(pic, pic_cadr(pic, spec), imports); import_table(pic, pic_cadr(pic, spec), imports);
pic_for_each (val, pic_cddr(pic, spec)) { pic_for_each (val, pic_cddr(pic, spec)) {
id = xh_val(xh_get_int(imports, pic_sym(pic_car(pic, val))), pic_sym); tmp = pic_dict_ref(pic, imports, pic_sym_ptr(pic_car(pic, val)));
xh_del_int(imports, pic_sym(pic_car(pic, val))); pic_dict_del(pic, imports, pic_sym_ptr(pic_car(pic, val)));
xh_put_int(imports, pic_sym(pic_cadr(pic, val)), &id); pic_dict_set(pic, imports, pic_sym_ptr(pic_cadr(pic, val)), tmp);
} }
goto exit; return;
} }
if (tag == pic->sPREFIX) { if (tag == pic->sPREFIX) {
import_table(pic, pic_cadr(pic, spec), &table); import_table(pic, pic_cadr(pic, spec), table);
for (it = xh_begin(&table); it != NULL; it = xh_next(it)) {
val = pic_list_ref(pic, spec, 2); prefix = pic_list_ref(pic, spec, 2);
sym = pic_intern_str(pic, pic_format(pic, "~s~s", val, pic_sym_value(xh_key(it, pic_sym)))); pic_dict_for_each (sym, table) {
xh_put_int(imports, sym, &xh_val(it, pic_sym)); id = pic_intern(pic, pic_format(pic, "~s~s", prefix, pic_obj_value(sym)));
pic_dict_set(pic, imports, id, pic_dict_ref(pic, table, sym));
} }
goto exit; return;
} }
if (tag == pic->sEXCEPT) { if (tag == pic->sEXCEPT) {
import_table(pic, pic_cadr(pic, spec), imports); import_table(pic, pic_cadr(pic, spec), imports);
pic_for_each (val, pic_cddr(pic, spec)) { pic_for_each (val, pic_cddr(pic, spec)) {
xh_del_int(imports, pic_sym(val)); pic_dict_del(pic, imports, pic_sym_ptr(val));
} }
goto exit; return;
} }
} }
lib = pic_find_library(pic, spec); lib = pic_find_library(pic, spec);
if (! lib) { if (! lib) {
pic_errorf(pic, "library not found: ~a", spec); pic_errorf(pic, "library not found: ~a", spec);
} }
for (it = xh_begin(&lib->exports); it != NULL; it = xh_next(it)) { pic_dict_for_each (sym, lib->exports) {
xh_put_int(imports, xh_key(it, pic_sym), &xh_val(it, pic_sym)); pic_dict_set(pic, imports, sym, pic_dict_ref(pic, lib->exports, sym));
} }
exit:
xh_destroy(&table);
} }
static void static void
import(pic_state *pic, pic_value spec) import(pic_state *pic, pic_value spec)
{ {
xhash imports; struct pic_dict *imports;
xh_entry *it; pic_sym *sym;
xh_init_int(&imports, sizeof(pic_sym)); /* pic_sym to pic_sym */ imports = pic_make_dict(pic);
import_table(pic, spec, &imports); import_table(pic, spec, imports);
for (it = xh_begin(&imports); it != NULL; it = xh_next(it)) { pic_dict_for_each (sym, imports) {
pic_put_rename(pic, pic->lib->env, sym, pic_sym_ptr(pic_dict_ref(pic, imports, sym)));
#if DEBUG
printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it, pic_sym)), pic_symbol_name(pic, xh_val(it, pic_sym)));
#endif
pic_put_rename(pic, pic->lib->env, xh_key(it, pic_sym), xh_val(it, pic_sym));
} }
xh_destroy(&imports);
} }
static void static void
export(pic_state *pic, pic_value spec) export(pic_state *pic, pic_value spec)
{ {
const pic_sym sRENAME = pic_intern_cstr(pic, "rename"); pic_sym *sRENAME = pic_intern_cstr(pic, "rename");
pic_value a, b; pic_value a, b;
pic_sym rename; pic_sym *rename;
if (pic_sym_p(spec)) { /* (export a) */ if (pic_sym_p(spec)) { /* (export a) */
a = b = spec; a = b = spec;
@ -160,7 +156,7 @@ export(pic_state *pic, pic_value spec)
goto fail; goto fail;
if (! (pic_length(pic, spec) == 3)) if (! (pic_length(pic, spec) == 3))
goto fail; goto fail;
if (! pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME))) if (! pic_eq_p(pic_car(pic, spec), pic_obj_value(sRENAME)))
goto fail; goto fail;
if (! pic_sym_p(a = pic_list_ref(pic, spec, 1))) if (! pic_sym_p(a = pic_list_ref(pic, spec, 1)))
goto fail; goto fail;
@ -168,15 +164,15 @@ export(pic_state *pic, pic_value spec)
goto fail; goto fail;
} }
if (! pic_find_rename(pic, pic->lib->env, pic_sym(a), &rename)) { if (! pic_find_rename(pic, pic->lib->env, pic_sym_ptr(a), &rename)) {
pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, pic_sym(a))); pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, pic_sym_ptr(a)));
} }
#if DEBUG #if DEBUG
printf("* exporting %s as %s\n", pic_symbol_name(pic, pic_sym(b)), pic_symbol_name(pic, rename)); printf("* exporting %s as %s\n", pic_symbol_name(pic, pic_sym_ptr(b)), pic_symbol_name(pic, rename));
#endif #endif
xh_put_int(&pic->lib->exports, pic_sym(b), &rename); pic_dict_set(pic, pic->lib->exports, pic_sym_ptr(b), pic_obj_value(rename));
return; return;
@ -197,18 +193,18 @@ pic_import_library(pic_state *pic, struct pic_lib *lib)
} }
void void
pic_export(pic_state *pic, pic_sym sym) pic_export(pic_state *pic, pic_sym *sym)
{ {
export(pic, pic_sym_value(sym)); export(pic, pic_obj_value(sym));
} }
static bool static bool
condexpand(pic_state *pic, pic_value clause) condexpand(pic_state *pic, pic_value clause)
{ {
pic_sym tag; pic_sym *tag;
pic_value c, feature; pic_value c, feature;
if (pic_eq_p(clause, pic_sym_value(pic->sELSE))) { if (pic_eq_p(clause, pic_obj_value(pic->sELSE))) {
return true; return true;
} }
if (pic_sym_p(clause)) { if (pic_sym_p(clause)) {
@ -222,7 +218,7 @@ condexpand(pic_state *pic, pic_value clause)
if (! (pic_pair_p(clause) && pic_sym_p(pic_car(pic, clause)))) { if (! (pic_pair_p(clause) && pic_sym_p(pic_car(pic, clause)))) {
pic_errorf(pic, "invalid 'cond-expand' clause ~s", clause); pic_errorf(pic, "invalid 'cond-expand' clause ~s", clause);
} else { } else {
tag = pic_sym(pic_car(pic, clause)); tag = pic_sym_ptr(pic_car(pic, clause));
} }
if (tag == pic->sLIBRARY) { if (tag == pic->sLIBRARY) {
@ -259,7 +255,7 @@ pic_lib_condexpand(pic_state *pic)
for (i = 0; i < argc; i++) { for (i = 0; i < argc; i++) {
if (condexpand(pic, pic_car(pic, clauses[i]))) { if (condexpand(pic, pic_car(pic, clauses[i]))) {
return pic_cons(pic, pic_sym_value(pic->rBEGIN), pic_cdr(pic, clauses[i])); return pic_cons(pic, pic_obj_value(pic->rBEGIN), pic_cdr(pic, clauses[i]));
} }
} }
@ -339,7 +335,7 @@ pic_lib_in_library(pic_state *pic)
void void
pic_init_lib(pic_state *pic) pic_init_lib(pic_state *pic)
{ {
void pic_defmacro(pic_state *, pic_sym, pic_sym, pic_func_t); void pic_defmacro(pic_state *, pic_sym *, pic_sym *, pic_func_t);
pic_defmacro(pic, pic->sCOND_EXPAND, pic->rCOND_EXPAND, pic_lib_condexpand); pic_defmacro(pic, pic->sCOND_EXPAND, pic->rCOND_EXPAND, pic_lib_condexpand);
pic_defmacro(pic, pic->sIMPORT, pic->rIMPORT, pic_lib_import); pic_defmacro(pic, pic->sIMPORT, pic->rIMPORT, pic_lib_import);

94
extlib/benz/macro.c
View File

@ -11,11 +11,12 @@
#include "picrin/error.h" #include "picrin/error.h"
#include "picrin/dict.h" #include "picrin/dict.h"
#include "picrin/cont.h" #include "picrin/cont.h"
#include "picrin/symbol.h"
pic_sym pic_sym *
pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym) pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym *sym)
{ {
pic_sym rename; pic_sym *rename;
rename = pic_gensym(pic, sym); rename = pic_gensym(pic, sym);
pic_put_rename(pic, senv, sym, rename); pic_put_rename(pic, senv, sym, rename);
@ -23,50 +24,42 @@ pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym)
} }
void void
pic_put_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rename) pic_put_rename(pic_state *pic, struct pic_senv *senv, pic_sym *sym, pic_sym *rename)
{ {
PIC_UNUSED(pic); pic_dict_set(pic, senv->map, sym, pic_obj_value(rename));
xh_put_int(&senv->map, sym, &rename);
} }
bool bool
pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *rename) pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym *sym, pic_sym **rename)
{ {
xh_entry *e; if (! pic_dict_has(pic, senv->map, sym)) {
PIC_UNUSED(pic);
if ((e = xh_get_int(&senv->map, sym)) == NULL) {
return false; return false;
} }
if (rename != NULL) { if (rename != NULL) {
*rename = xh_val(e, pic_sym); *rename = pic_sym_ptr(pic_dict_ref(pic, senv->map, sym));
} }
return true; return true;
} }
static void static void
define_macro(pic_state *pic, pic_sym rename, struct pic_proc *mac) define_macro(pic_state *pic, pic_sym *rename, struct pic_proc *mac)
{ {
xh_put_int(&pic->macros, rename, &mac); pic_dict_set(pic, pic->macros, rename, pic_obj_value(mac));
} }
static struct pic_proc * static struct pic_proc *
find_macro(pic_state *pic, pic_sym rename) find_macro(pic_state *pic, pic_sym *rename)
{ {
xh_entry *e; if (! pic_dict_has(pic, pic->macros, rename)) {
if ((e = xh_get_int(&pic->macros, rename)) == NULL) {
return NULL; return NULL;
} }
return xh_val(e, struct pic_proc *); return pic_proc_ptr(pic_dict_ref(pic, pic->macros, rename));
} }
static pic_sym static pic_sym *
make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv) make_identifier(pic_state *pic, pic_sym *sym, struct pic_senv *senv)
{ {
pic_sym rename; pic_sym *rename;
while (true) { while (true) {
if (pic_find_rename(pic, senv, sym, &rename)) { if (pic_find_rename(pic, senv, sym, &rename)) {
@ -88,15 +81,15 @@ static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *);
static pic_value macroexpand_lambda(pic_state *, pic_value, struct pic_senv *); static pic_value macroexpand_lambda(pic_state *, pic_value, struct pic_senv *);
static pic_value static pic_value
macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv) macroexpand_symbol(pic_state *pic, pic_sym *sym, struct pic_senv *senv)
{ {
return pic_sym_value(make_identifier(pic, sym, senv)); return pic_obj_value(make_identifier(pic, sym, senv));
} }
static pic_value static pic_value
macroexpand_quote(pic_state *pic, pic_value expr) macroexpand_quote(pic_state *pic, pic_value expr)
{ {
return pic_cons(pic, pic_sym_value(pic->rQUOTE), pic_cdr(pic, expr)); return pic_cons(pic, pic_obj_value(pic->rQUOTE), pic_cdr(pic, expr));
} }
static pic_value static pic_value
@ -166,10 +159,10 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv)
if (! pic_sym_p(v)) { if (! pic_sym_p(v)) {
pic_errorf(pic, "syntax error"); pic_errorf(pic, "syntax error");
} }
pic_add_rename(pic, in, pic_sym(v)); pic_add_rename(pic, in, pic_sym_ptr(v));
} }
if (pic_sym_p(a)) { if (pic_sym_p(a)) {
pic_add_rename(pic, in, pic_sym(a)); pic_add_rename(pic, in, pic_sym_ptr(a));
} }
else if (! pic_nil_p(a)) { else if (! pic_nil_p(a)) {
pic_errorf(pic, "syntax error"); pic_errorf(pic, "syntax error");
@ -180,20 +173,20 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv)
macroexpand_deferred(pic, in); macroexpand_deferred(pic, in);
return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body)); return pic_cons(pic, pic_obj_value(pic->rLAMBDA), pic_cons(pic, formal, body));
} }
static pic_value static pic_value
macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv) macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv)
{ {
pic_sym sym, rename; pic_sym *sym, *rename;
pic_value var, val; pic_value var, val;
while (pic_length(pic, expr) >= 2 && pic_pair_p(pic_cadr(pic, expr))) { while (pic_length(pic, expr) >= 2 && pic_pair_p(pic_cadr(pic, expr))) {
var = pic_car(pic, pic_cadr(pic, expr)); var = pic_car(pic, pic_cadr(pic, expr));
val = pic_cdr(pic, pic_cadr(pic, expr)); val = pic_cdr(pic, pic_cadr(pic, expr));
expr = pic_list3(pic, pic_sym_value(pic->rDEFINE), var, pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr)))); expr = pic_list3(pic, pic_obj_value(pic->rDEFINE), var, pic_cons(pic, pic_obj_value(pic->rLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr))));
} }
if (pic_length(pic, expr) != 3) { if (pic_length(pic, expr) != 3) {
@ -204,20 +197,20 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv)
if (! pic_sym_p(var)) { if (! pic_sym_p(var)) {
pic_errorf(pic, "binding to non-symbol object"); pic_errorf(pic, "binding to non-symbol object");
} }
sym = pic_sym(var); sym = pic_sym_ptr(var);
if (! pic_find_rename(pic, senv, sym, &rename)) { if (! pic_find_rename(pic, senv, sym, &rename)) {
rename = pic_add_rename(pic, senv, sym); rename = pic_add_rename(pic, senv, sym);
} }
val = macroexpand(pic, pic_list_ref(pic, expr, 2), senv); val = macroexpand(pic, pic_list_ref(pic, expr, 2), senv);
return pic_list3(pic, pic_sym_value(pic->rDEFINE), pic_sym_value(rename), val); return pic_list3(pic, pic_obj_value(pic->rDEFINE), pic_obj_value(rename), val);
} }
static pic_value static pic_value
macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv) macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
{ {
pic_value var, val; pic_value var, val;
pic_sym sym, rename; pic_sym *sym, *rename;
if (pic_length(pic, expr) != 3) { if (pic_length(pic, expr) != 3) {
pic_errorf(pic, "syntax error"); pic_errorf(pic, "syntax error");
@ -227,11 +220,11 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
if (! pic_sym_p(var)) { if (! pic_sym_p(var)) {
pic_errorf(pic, "binding to non-symbol object"); pic_errorf(pic, "binding to non-symbol object");
} }
sym = pic_sym(var); sym = pic_sym_ptr(var);
if (! pic_find_rename(pic, senv, sym, &rename)) { if (! pic_find_rename(pic, senv, sym, &rename)) {
rename = pic_add_rename(pic, senv, sym); rename = pic_add_rename(pic, senv, sym);
} else { } else {
pic_warnf(pic, "redefining syntax variable: ~s", pic_sym_value(sym)); pic_warnf(pic, "redefining syntax variable: ~s", pic_obj_value(sym));
} }
val = pic_cadr(pic, pic_cdr(pic, expr)); val = pic_cadr(pic, pic_cdr(pic, expr));
@ -290,7 +283,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
{ {
switch (pic_type(expr)) { switch (pic_type(expr)) {
case PIC_TT_SYMBOL: { case PIC_TT_SYMBOL: {
return macroexpand_symbol(pic, pic_sym(expr), senv); return macroexpand_symbol(pic, pic_sym_ptr(expr), senv);
} }
case PIC_TT_PAIR: { case PIC_TT_PAIR: {
pic_value car; pic_value car;
@ -302,7 +295,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
car = macroexpand(pic, pic_car(pic, expr), senv); car = macroexpand(pic, pic_car(pic, expr), senv);
if (pic_sym_p(car)) { if (pic_sym_p(car)) {
pic_sym tag = pic_sym(car); pic_sym *tag = pic_sym_ptr(car);
if (tag == pic->rDEFINE_SYNTAX) { if (tag == pic->rDEFINE_SYNTAX) {
return macroexpand_defsyntax(pic, expr, senv); return macroexpand_defsyntax(pic, expr, senv);
@ -385,11 +378,14 @@ struct pic_senv *
pic_make_senv(pic_state *pic, struct pic_senv *up) pic_make_senv(pic_state *pic, struct pic_senv *up)
{ {
struct pic_senv *senv; struct pic_senv *senv;
struct pic_dict *map;
map = pic_make_dict(pic);
senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
senv->up = up; senv->up = up;
senv->defer = pic_nil_value(); senv->defer = pic_nil_value();
xh_init_int(&senv->map, sizeof(pic_sym)); senv->map = map;
return senv; return senv;
} }
@ -411,7 +407,7 @@ pic_null_syntactic_environment(pic_state *pic)
} }
void void
pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rsym) pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym *sym, pic_sym *rsym)
{ {
pic_put_rename(pic, senv, sym, rsym); pic_put_rename(pic, senv, sym, rsym);
@ -434,7 +430,7 @@ defmacro_call(pic_state *pic)
} }
void void
pic_defmacro(pic_state *pic, pic_sym name, pic_sym id, pic_func_t func) pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func)
{ {
struct pic_proc *proc, *trans; struct pic_proc *proc, *trans;
@ -455,13 +451,13 @@ pic_defmacro(pic_state *pic, pic_sym name, pic_sym id, pic_func_t func)
bool bool
pic_identifier_p(pic_state *pic, pic_value obj) pic_identifier_p(pic_state *pic, pic_value obj)
{ {
return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym(obj)); return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym_ptr(obj));
} }
bool bool
pic_identifier_eq_p(pic_state *pic, struct pic_senv *env1, pic_sym sym1, struct pic_senv *env2, pic_sym sym2) pic_identifier_eq_p(pic_state *pic, struct pic_senv *env1, pic_sym *sym1, struct pic_senv *env2, pic_sym *sym2)
{ {
pic_sym a, b; pic_sym *a, *b;
a = make_identifier(pic, sym1, env1); a = make_identifier(pic, sym1, env1);
if (a != make_identifier(pic, sym1, env1)) { if (a != make_identifier(pic, sym1, env1)) {
@ -473,7 +469,7 @@ pic_identifier_eq_p(pic_state *pic, struct pic_senv *env1, pic_sym sym1, struct
b = sym2; b = sym2;
} }
return pic_eq_p(pic_sym_value(a), pic_sym_value(b)); return pic_eq_p(pic_obj_value(a), pic_obj_value(b));
} }
static pic_value static pic_value
@ -490,19 +486,19 @@ static pic_value
pic_macro_make_identifier(pic_state *pic) pic_macro_make_identifier(pic_state *pic)
{ {
pic_value obj; pic_value obj;
pic_sym sym; pic_sym *sym;
pic_get_args(pic, "mo", &sym, &obj); pic_get_args(pic, "mo", &sym, &obj);
pic_assert_type(pic, obj, senv); pic_assert_type(pic, obj, senv);
return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj))); return pic_obj_value(make_identifier(pic, sym, pic_senv_ptr(obj)));
} }
static pic_value static pic_value
pic_macro_identifier_eq_p(pic_state *pic) pic_macro_identifier_eq_p(pic_state *pic)
{ {
pic_sym sym1, sym2; pic_sym *sym1, *sym2;
pic_value env1, env2; pic_value env1, env2;
pic_get_args(pic, "omom", &env1, &sym1, &env2, &sym2); pic_get_args(pic, "omom", &env1, &sym1, &env2, &sym2);

2
extlib/benz/proc.c
View File

@ -34,7 +34,7 @@ pic_make_proc_irep(pic_state *pic, struct pic_irep *irep, struct pic_env *env)
return proc; return proc;
} }
pic_sym pic_sym *
pic_proc_name(struct pic_proc *proc) pic_proc_name(struct pic_proc *proc)
{ {
switch (proc->kind) { switch (proc->kind) {

28
extlib/benz/read.c
View File

@ -11,6 +11,7 @@
#include "picrin/blob.h" #include "picrin/blob.h"
#include "picrin/port.h" #include "picrin/port.h"
#include "picrin/proc.h" #include "picrin/proc.h"
#include "picrin/symbol.h"
static pic_value read(pic_state *pic, struct pic_port *port, int c); static pic_value read(pic_state *pic, struct pic_port *port, int c);
static pic_value read_nullable(pic_state *pic, struct pic_port *port, int c); static pic_value read_nullable(pic_state *pic, struct pic_port *port, int c);
@ -166,7 +167,7 @@ read_quote(pic_state *pic, struct pic_port *port, const char *str)
{ {
PIC_UNUSED(str); PIC_UNUSED(str);
return pic_list2(pic, pic_sym_value(pic->sQUOTE), read(pic, port, next(port))); return pic_list2(pic, pic_obj_value(pic->sQUOTE), read(pic, port, next(port)));
} }
static pic_value static pic_value
@ -174,7 +175,7 @@ read_quasiquote(pic_state *pic, struct pic_port *port, const char *str)
{ {
PIC_UNUSED(str); PIC_UNUSED(str);
return pic_list2(pic, pic_sym_value(pic->sQUASIQUOTE), read(pic, port, next(port))); return pic_list2(pic, pic_obj_value(pic->sQUASIQUOTE), read(pic, port, next(port)));
} }
static pic_value static pic_value
@ -182,7 +183,7 @@ read_unquote(pic_state *pic, struct pic_port *port, const char *str)
{ {
PIC_UNUSED(str); PIC_UNUSED(str);
return pic_list2(pic, pic_sym_value(pic->sUNQUOTE), read(pic, port, next(port))); return pic_list2(pic, pic_obj_value(pic->sUNQUOTE), read(pic, port, next(port)));
} }
static pic_value static pic_value
@ -190,7 +191,7 @@ read_unquote_splicing(pic_state *pic, struct pic_port *port, const char *str)
{ {
PIC_UNUSED(str); PIC_UNUSED(str);
return pic_list2(pic, pic_sym_value(pic->sUNQUOTE_SPLICING), read(pic, port, next(port))); return pic_list2(pic, pic_obj_value(pic->sUNQUOTE_SPLICING), read(pic, port, next(port)));
} }
static pic_value static pic_value
@ -198,7 +199,7 @@ read_symbol(pic_state *pic, struct pic_port *port, const char *str)
{ {
size_t len, i; size_t len, i;
char *buf; char *buf;
pic_sym sym; pic_sym *sym;
int c; int c;
len = strlen(str); len = strlen(str);
@ -222,10 +223,11 @@ read_symbol(pic_state *pic, struct pic_port *port, const char *str)
buf[len - 1] = (char)c; buf[len - 1] = (char)c;
} }
sym = pic_intern(pic, buf, len); buf[len] = 0;
sym = pic_intern_cstr(pic, buf);
pic_free(pic, buf); pic_free(pic, buf);
return pic_sym_value(sym); return pic_obj_value(sym);
} }
static size_t static size_t
@ -318,10 +320,10 @@ read_minus(pic_state *pic, struct pic_port *port, const char *str)
} }
else { else {
sym = read_symbol(pic, port, str); sym = read_symbol(pic, port, str);
if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "-inf.0")) { if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-inf.0")) {
return pic_float_value(-INFINITY); return pic_float_value(-INFINITY);
} }
if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "-nan.0")) { if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-nan.0")) {
return pic_float_value(-NAN); return pic_float_value(-NAN);
} }
return sym; return sym;
@ -338,10 +340,10 @@ read_plus(pic_state *pic, struct pic_port *port, const char *str)
} }
else { else {
sym = read_symbol(pic, port, str); sym = read_symbol(pic, port, str);
if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "+inf.0")) { if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+inf.0")) {
return pic_float_value(INFINITY); return pic_float_value(INFINITY);
} }
if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "+nan.0")) { if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+nan.0")) {
return pic_float_value(NAN); return pic_float_value(NAN);
} }
return sym; return sym;
@ -450,7 +452,7 @@ read_pipe(pic_state *pic, struct pic_port *port, const char *str)
{ {
char *buf; char *buf;
size_t size, cnt; size_t size, cnt;
pic_sym sym; pic_sym *sym;
/* Currently supports only ascii chars */ /* Currently supports only ascii chars */
char HEX_BUF[3]; char HEX_BUF[3];
size_t i = 0; size_t i = 0;
@ -489,7 +491,7 @@ read_pipe(pic_state *pic, struct pic_port *port, const char *str)
sym = pic_intern_cstr(pic, buf); sym = pic_intern_cstr(pic, buf);
pic_free(pic, buf); pic_free(pic, buf);
return pic_sym_value(sym); return pic_obj_value(sym);
} }
static pic_value static pic_value

27
extlib/benz/record.c
View File

@ -4,14 +4,18 @@
#include "picrin.h" #include "picrin.h"
#include "picrin/record.h" #include "picrin/record.h"
#include "picrin/dict.h"
struct pic_record * struct pic_record *
pic_make_record(pic_state *pic, pic_value rectype) pic_make_record(pic_state *pic, pic_value rectype)
{ {
struct pic_record *rec; struct pic_record *rec;
struct pic_dict *data;
data = pic_make_dict(pic);
rec = (struct pic_record *)pic_obj_alloc(pic, sizeof(struct pic_record), PIC_TT_RECORD); rec = (struct pic_record *)pic_obj_alloc(pic, sizeof(struct pic_record), PIC_TT_RECORD);
xh_init_int(&rec->hash, sizeof(pic_value)); rec->data = data;
pic_record_set(pic, rec, pic_intern_cstr(pic, "@@type"), rectype); pic_record_set(pic, rec, pic_intern_cstr(pic, "@@type"), rectype);
@ -25,23 +29,18 @@ pic_record_type(pic_state *pic, struct pic_record *rec)
} }
pic_value pic_value
pic_record_ref(pic_state *pic, struct pic_record *rec, pic_sym slot) pic_record_ref(pic_state *pic, struct pic_record *rec, pic_sym *slot)
{ {
xh_entry *e; if (! pic_dict_has(pic, rec->data, slot)) {
pic_errorf(pic, "slot named ~s is not found for record: ~s", pic_obj_value(slot), rec);
e = xh_get_int(&rec->hash, slot);
if (! e) {
pic_errorf(pic, "slot named ~s is not found for record: ~s", pic_sym_value(slot), rec);
} }
return xh_val(e, pic_value); return pic_dict_ref(pic, rec->data, slot);
} }
void void
pic_record_set(pic_state *pic, struct pic_record *rec, pic_sym slot, pic_value val) pic_record_set(pic_state *pic, struct pic_record *rec, pic_sym *slot, pic_value val)
{ {
PIC_UNUSED(pic); pic_dict_set(pic, rec->data, slot, val);
xh_put_int(&rec->hash, slot, &val);
} }
static pic_value static pic_value
@ -81,7 +80,7 @@ static pic_value
pic_record_record_ref(pic_state *pic) pic_record_record_ref(pic_state *pic)
{ {
struct pic_record *rec; struct pic_record *rec;
pic_sym slot; pic_sym *slot;
pic_get_args(pic, "rm", &rec, &slot); pic_get_args(pic, "rm", &rec, &slot);
@ -92,7 +91,7 @@ static pic_value
pic_record_record_set(pic_state *pic) pic_record_record_set(pic_state *pic)
{ {
struct pic_record *rec; struct pic_record *rec;
pic_sym slot; pic_sym *slot;
pic_value val; pic_value val;
pic_get_args(pic, "rmo", &rec, &slot, &val); pic_get_args(pic, "rmo", &rec, &slot, &val);

77
extlib/benz/state.c
View File

@ -10,6 +10,7 @@
#include "picrin/cont.h" #include "picrin/cont.h"
#include "picrin/port.h" #include "picrin/port.h"
#include "picrin/error.h" #include "picrin/error.h"
#include "picrin/dict.h"
void pic_init_core(pic_state *); void pic_init_core(pic_state *);
@ -24,6 +25,9 @@ pic_open(int argc, char *argv[], char **envp)
pic = malloc(sizeof(pic_state)); pic = malloc(sizeof(pic_state));
/* turn off GC */
pic->gc_enable = false;
/* root block */ /* root block */
pic->wind = NULL; pic->wind = NULL;
@ -48,16 +52,13 @@ pic_open(int argc, char *argv[], char **envp)
pic->heap = pic_heap_open(); pic->heap = pic_heap_open();
/* symbol table */ /* symbol table */
xh_init_str(&pic->syms, sizeof(pic_sym)); xh_init_str(&pic->syms, sizeof(pic_sym *));
xh_init_int(&pic->sym_names, sizeof(const char *));
pic->sym_cnt = 0;
pic->uniq_sym_cnt = 0;
/* global variables */ /* global variables */
xh_init_int(&pic->globals, sizeof(pic_value)); pic->globals = NULL;
/* macros */ /* macros */
xh_init_int(&pic->macros, sizeof(struct pic_macro *)); pic->macros = NULL;
/* attributes */ /* attributes */
xh_init_ptr(&pic->attrs, sizeof(struct pic_dict *)); xh_init_ptr(&pic->attrs, sizeof(struct pic_dict *));
@ -69,11 +70,10 @@ pic_open(int argc, char *argv[], char **envp)
pic->libs = pic_nil_value(); pic->libs = pic_nil_value();
pic->lib = NULL; pic->lib = NULL;
/* reader */ /* GC arena */
pic->reader = malloc(sizeof(struct pic_reader)); pic->arena = calloc(PIC_ARENA_SIZE, sizeof(struct pic_object **));
pic->reader->typecase = PIC_CASE_DEFAULT; pic->arena_size = PIC_ARENA_SIZE;
pic->reader->trie = pic_make_trie(pic); pic->arena_idx = 0;
xh_init_int(&pic->reader->labels, sizeof(pic_value));
/* raised error object */ /* raised error object */
pic->err = pic_undef_value(); pic->err = pic_undef_value();
@ -83,17 +83,13 @@ pic_open(int argc, char *argv[], char **envp)
pic->xSTDOUT = NULL; pic->xSTDOUT = NULL;
pic->xSTDERR = NULL; pic->xSTDERR = NULL;
/* GC arena */
pic->arena = calloc(PIC_ARENA_SIZE, sizeof(struct pic_object **));
pic->arena_size = PIC_ARENA_SIZE;
pic->arena_idx = 0;
/* native stack marker */ /* native stack marker */
pic->native_stack_start = &t; pic->native_stack_start = &t;
ai = pic_gc_arena_preserve(pic);
#define S(slot,name) pic->slot = pic_intern_cstr(pic, name); #define S(slot,name) pic->slot = pic_intern_cstr(pic, name);
ai = pic_gc_arena_preserve(pic);
S(sDEFINE, "define"); S(sDEFINE, "define");
S(sLAMBDA, "lambda"); S(sLAMBDA, "lambda");
S(sIF, "if"); S(sIF, "if");
@ -121,8 +117,8 @@ pic_open(int argc, char *argv[], char **envp)
S(sCAR, "car"); S(sCAR, "car");
S(sCDR, "cdr"); S(sCDR, "cdr");
S(sNILP, "null?"); S(sNILP, "null?");
S(sSYMBOL_P, "symbol?"); S(sSYMBOLP, "symbol?");
S(sPAIR_P, "pair?"); S(sPAIRP, "pair?");
S(sADD, "+"); S(sADD, "+");
S(sSUB, "-"); S(sSUB, "-");
S(sMUL, "*"); S(sMUL, "*");
@ -136,11 +132,19 @@ pic_open(int argc, char *argv[], char **envp)
S(sNOT, "not"); S(sNOT, "not");
S(sREAD, "read"); S(sREAD, "read");
S(sFILE, "file"); S(sFILE, "file");
S(sCALL, "call");
S(sTAILCALL, "tail-call");
S(sGREF, "gref");
S(sLREF, "lref");
S(sCREF, "cref");
S(sRETURN, "return");
S(sCALL_WITH_VALUES, "call-with-values");
S(sTAILCALL_WITH_VALUES, "tailcall-with-values");
pic_gc_arena_restore(pic, ai); pic_gc_arena_restore(pic, ai);
#define R(slot,name) pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name)); #define R(slot,name) pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name));
ai = pic_gc_arena_preserve(pic);
R(rDEFINE, "define"); R(rDEFINE, "define");
R(rLAMBDA, "lambda"); R(rLAMBDA, "lambda");
R(rIF, "if"); R(rIF, "if");
@ -155,12 +159,22 @@ pic_open(int argc, char *argv[], char **envp)
R(rCOND_EXPAND, "cond-expand"); R(rCOND_EXPAND, "cond-expand");
pic_gc_arena_restore(pic, ai); pic_gc_arena_restore(pic, ai);
/* root tables */
pic->globals = pic_make_dict(pic);
pic->macros = pic_make_dict(pic);
/* root block */ /* root block */
pic->wind = pic_alloc(pic, sizeof(struct pic_winder)); pic->wind = pic_alloc(pic, sizeof(struct pic_winder));
pic->wind->prev = NULL; pic->wind->prev = NULL;
pic->wind->depth = 0; pic->wind->depth = 0;
pic->wind->in = pic->wind->out = NULL; pic->wind->in = pic->wind->out = NULL;
/* reader */
pic->reader = malloc(sizeof(struct pic_reader));
pic->reader->typecase = PIC_CASE_DEFAULT;
pic->reader->trie = pic_make_trie(pic);
xh_init_int(&pic->reader->labels, sizeof(pic_value));
/* init readers */ /* init readers */
pic_init_reader(pic); pic_init_reader(pic);
@ -174,6 +188,11 @@ pic_open(int argc, char *argv[], char **envp)
pic->xSTDOUT = pic_make_standard_port(pic, xstdout, PIC_PORT_OUT); pic->xSTDOUT = pic_make_standard_port(pic, xstdout, PIC_PORT_OUT);
pic->xSTDERR = pic_make_standard_port(pic, xstderr, PIC_PORT_OUT); pic->xSTDERR = pic_make_standard_port(pic, xstderr, PIC_PORT_OUT);
pic_gc_arena_restore(pic, ai);
/* turn on GC */
pic->gc_enable = true;
pic_init_core(pic); pic_init_core(pic);
return pic; return pic;
@ -192,14 +211,20 @@ pic_close(pic_state *pic)
pic->wind = pic->wind->prev; pic->wind = pic->wind->prev;
} }
/* free symbol names */
for (it = xh_begin(&pic->syms); it != NULL; it = xh_next(it)) {
free(xh_key(it, char *));
}
/* clear out root objects */ /* clear out root objects */
pic->sp = pic->stbase; pic->sp = pic->stbase;
pic->ci = pic->cibase; pic->ci = pic->cibase;
pic->xp = pic->xpbase; pic->xp = pic->xpbase;
pic->arena_idx = 0; pic->arena_idx = 0;
pic->err = pic_undef_value(); pic->err = pic_undef_value();
xh_clear(&pic->globals); pic->globals = NULL;
xh_clear(&pic->macros); pic->macros = NULL;
xh_clear(&pic->syms);
xh_clear(&pic->attrs); xh_clear(&pic->attrs);
pic->features = pic_nil_value(); pic->features = pic_nil_value();
pic->libs = pic_nil_value(); pic->libs = pic_nil_value();
@ -222,18 +247,10 @@ pic_close(pic_state *pic)
/* free global stacks */ /* free global stacks */
xh_destroy(&pic->syms); xh_destroy(&pic->syms);
xh_destroy(&pic->globals);
xh_destroy(&pic->macros);
xh_destroy(&pic->attrs); xh_destroy(&pic->attrs);
/* free GC arena */ /* free GC arena */
free(pic->arena); free(pic->arena);
/* free symbol names */
for (it = xh_begin(&pic->sym_names); it != NULL; it = xh_next(it)) {
free(xh_val(it, char *));
}
xh_destroy(&pic->sym_names);
free(pic); free(pic);
} }

134
extlib/benz/symbol.c
View File

@ -3,92 +3,72 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "picrin/symbol.h"
#include "picrin/string.h" #include "picrin/string.h"
pic_sym pic_sym *
pic_intern(pic_state *pic, const char *str, size_t len) pic_make_symbol(pic_state *pic, pic_str *str)
{ {
char *cstr; pic_sym *sym;
xh_entry *e;
pic_sym id;
cstr = (char *)pic_malloc(pic, len + 1); sym = (pic_sym *)pic_obj_alloc(pic, sizeof(struct pic_symbol), PIC_TT_SYMBOL);
cstr[len] = '\0'; sym->str = str;
memcpy(cstr, str, len); return sym;
e = xh_get_str(&pic->syms, cstr);
if (e) {
return xh_val(e, pic_sym);
}
id = pic->sym_cnt++;
xh_put_str(&pic->syms, cstr, &id);
xh_put_int(&pic->sym_names, id, &cstr);
return id;
} }
pic_sym pic_sym *
pic_intern(pic_state *pic, pic_str *str)
{
xh_entry *e;
pic_sym *sym;
char *cstr;
e = xh_get_str(&pic->syms, pic_str_cstr(str));
if (e) {
sym = xh_val(e, pic_sym *);
pic_gc_protect(pic, pic_obj_value(sym));
return sym;
}
cstr = pic_malloc(pic, pic_strlen(str) + 1);
strcpy(cstr, pic_str_cstr(str));
sym = pic_make_symbol(pic, str);
xh_put_str(&pic->syms, cstr, &sym);
return sym;
}
pic_sym *
pic_intern_cstr(pic_state *pic, const char *str) pic_intern_cstr(pic_state *pic, const char *str)
{ {
return pic_intern(pic, str, strlen(str)); return pic_intern(pic, pic_make_str(pic, str, strlen(str)));
} }
pic_sym pic_sym *
pic_intern_str(pic_state *pic, pic_str *str) pic_gensym(pic_state *pic, pic_sym *base)
{ {
return pic_intern_cstr(pic, pic_str_cstr(str)); return pic_make_symbol(pic, base->str);
}
pic_sym
pic_gensym(pic_state *pic, pic_sym base)
{
int uid = pic->uniq_sym_cnt++, len;
char *str, mark;
pic_sym uniq;
if (pic_interned_p(pic, base)) {
mark = '@';
} else {
mark = '.';
}
len = snprintf(NULL, 0, "%s%c%d", pic_symbol_name(pic, base), mark, uid);
str = pic_alloc(pic, (size_t)len + 1);
sprintf(str, "%s%c%d", pic_symbol_name(pic, base), mark, uid);
/* don't put the symbol to pic->syms to keep it uninterned */
uniq = pic->sym_cnt++;
xh_put_int(&pic->sym_names, uniq, &str);
return uniq;
}
pic_sym
pic_ungensym(pic_state *pic, pic_sym base)
{
const char *name, *occr;
if (pic_interned_p(pic, base)) {
return base;
}
name = pic_symbol_name(pic, base);
if ((occr = strrchr(name, '@')) == NULL) {
pic_panic(pic, "logic flaw");
}
return pic_intern(pic, name, (size_t)(occr - name));
} }
bool bool
pic_interned_p(pic_state *pic, pic_sym sym) pic_interned_p(pic_state *pic, pic_sym *sym)
{ {
return sym == pic_intern_cstr(pic, pic_symbol_name(pic, sym)); xh_entry *e;
e = xh_get_str(&pic->syms, pic_str_cstr(sym->str));
if (e) {
return sym == xh_val(e, pic_sym *);
} else {
return false;
}
} }
const char * const char *
pic_symbol_name(pic_state *pic, pic_sym sym) pic_symbol_name(pic_state *pic, pic_sym *sym)
{ {
return xh_val(xh_get_int(&pic->sym_names, sym), const char *); PIC_UNUSED(pic);
return pic_str_cstr(sym->str);
} }
static pic_value static pic_value
@ -123,29 +103,21 @@ pic_symbol_symbol_eq_p(pic_state *pic)
static pic_value static pic_value
pic_symbol_symbol_to_string(pic_state *pic) pic_symbol_symbol_to_string(pic_state *pic)
{ {
pic_value v; pic_sym *sym;
pic_get_args(pic, "o", &v); pic_get_args(pic, "m", &sym);
if (! pic_sym_p(v)) { return pic_obj_value(sym->str);
pic_errorf(pic, "symbol->string: expected symbol");
}
return pic_obj_value(pic_make_str_cstr(pic, pic_symbol_name(pic, pic_sym(v))));
} }
static pic_value static pic_value
pic_symbol_string_to_symbol(pic_state *pic) pic_symbol_string_to_symbol(pic_state *pic)
{ {
pic_value v; pic_str *str;
pic_get_args(pic, "o", &v); pic_get_args(pic, "s", &str);
if (! pic_str_p(v)) { return pic_obj_value(pic_intern(pic, str));
pic_errorf(pic, "string->symbol: expected string");
}
return pic_symbol_value(pic_intern_cstr(pic, pic_str_cstr(pic_str_ptr(v))));
} }
void void

71
extlib/benz/vm.c
View File

@ -15,6 +15,7 @@
#include "picrin/error.h" #include "picrin/error.h"
#include "picrin/dict.h" #include "picrin/dict.h"
#include "picrin/record.h" #include "picrin/record.h"
#include "picrin/symbol.h"
#define GET_OPERAND(pic,n) ((pic)->ci->fp[(n)]) #define GET_OPERAND(pic,n) ((pic)->ci->fp[(n)])
@ -40,7 +41,7 @@ pic_get_proc(pic_state *pic)
* F double *, bool * float with exactness * F double *, bool * float with exactness
* s pic_str ** string object * s pic_str ** string object
* z char ** c string * z char ** c string
* m pic_sym * symbol * m pic_sym ** symbol
* v pic_vec ** vector object * v pic_vec ** vector object
* b pic_blob ** bytevector object * b pic_blob ** bytevector object
* c char * char * c char * char
@ -254,14 +255,14 @@ pic_get_args(pic_state *pic, const char *format, ...)
break; break;
} }
case 'm': { case 'm': {
pic_sym *m; pic_sym **m;
pic_value v; pic_value v;
m = va_arg(ap, pic_sym *); m = va_arg(ap, pic_sym **);
if (i < argc) { if (i < argc) {
v = GET_OPERAND(pic,i); v = GET_OPERAND(pic,i);
if (pic_sym_p(v)) { if (pic_sym_p(v)) {
*m = pic_sym(v); *m = pic_sym_ptr(v);
} }
else { else {
pic_errorf(pic, "pic_get_args: expected symbol, but got ~s", v); pic_errorf(pic, "pic_get_args: expected symbol, but got ~s", v);
@ -432,7 +433,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
void void
pic_define_noexport(pic_state *pic, const char *name, pic_value val) pic_define_noexport(pic_state *pic, const char *name, pic_value val)
{ {
pic_sym sym, rename; pic_sym *sym, *rename;
sym = pic_intern_cstr(pic, name); sym = pic_intern_cstr(pic, name);
@ -442,7 +443,7 @@ pic_define_noexport(pic_state *pic, const char *name, pic_value val)
pic_warn(pic, "redefining global"); pic_warn(pic, "redefining global");
} }
xh_put_int(&pic->globals, rename, &val); pic_dict_set(pic, pic->globals, rename, val);
} }
void void
@ -456,7 +457,7 @@ pic_define(pic_state *pic, const char *name, pic_value val)
pic_value pic_value
pic_ref(pic_state *pic, struct pic_lib *lib, const char *name) pic_ref(pic_state *pic, struct pic_lib *lib, const char *name)
{ {
pic_sym sym, rename; pic_sym *sym, *rename;
sym = pic_intern_cstr(pic, name); sym = pic_intern_cstr(pic, name);
@ -464,13 +465,13 @@ pic_ref(pic_state *pic, struct pic_lib *lib, const char *name)
pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name);
} }
return xh_val(xh_get_int(&pic->globals, rename), pic_value); return pic_dict_ref(pic, pic->globals, rename);
} }
void void
pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val) pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val)
{ {
pic_sym sym, rename; pic_sym *sym, *rename;
sym = pic_intern_cstr(pic, name); sym = pic_intern_cstr(pic, name);
@ -478,7 +479,7 @@ pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val)
pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name); pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name);
} }
xh_put_int(&pic->globals, rename, &val); pic_dict_set(pic, pic->globals, rename, val);
} }
pic_value pic_value
@ -550,6 +551,23 @@ pic_vm_tear_off(pic_state *pic)
} }
} }
static struct pic_irep *
vm_get_irep(pic_state *pic)
{
pic_value self;
struct pic_irep *irep;
self = pic->ci->fp[0];
if (! pic_proc_p(self)) {
pic_errorf(pic, "logic flaw");
}
irep = pic_proc_ptr(self)->u.irep;
if (! pic_proc_irep_p(pic_proc_ptr(self))) {
pic_errorf(pic, "logic flaw");
}
return irep;
}
pic_value pic_value
pic_apply0(pic_state *pic, struct pic_proc *proc) pic_apply0(pic_state *pic, struct pic_proc *proc)
{ {
@ -688,7 +706,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
&&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_LSET, &&L_OP_CREF, &&L_OP_CSET, &&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_LSET, &&L_OP_CREF, &&L_OP_CSET,
&&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_NOT, &&L_OP_CALL, &&L_OP_TAILCALL, &&L_OP_RET, &&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_NOT, &&L_OP_CALL, &&L_OP_TAILCALL, &&L_OP_RET,
&&L_OP_LAMBDA, &&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP, &&L_OP_LAMBDA, &&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP,
&&L_OP_SYMBOL_P, &&L_OP_PAIR_P, &&L_OP_SYMBOLP, &&L_OP_PAIRP,
&&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV, &&L_OP_MINUS, &&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV, &&L_OP_MINUS,
&&L_OP_EQ, &&L_OP_LT, &&L_OP_LE, &&L_OP_STOP &&L_OP_EQ, &&L_OP_LT, &&L_OP_LE, &&L_OP_STOP
}; };
@ -751,34 +769,31 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
NEXT; NEXT;
} }
CASE(OP_PUSHCONST) { CASE(OP_PUSHCONST) {
pic_value self; struct pic_irep *irep = vm_get_irep(pic);
struct pic_irep *irep;
self = pic->ci->fp[0];
if (! pic_proc_p(self)) {
pic_errorf(pic, "logic flaw");
}
irep = pic_proc_ptr(self)->u.irep;
if (! pic_proc_irep_p(pic_proc_ptr(self))) {
pic_errorf(pic, "logic flaw");
}
PUSH(irep->pool[c.u.i]); PUSH(irep->pool[c.u.i]);
NEXT; NEXT;
} }
CASE(OP_GREF) { CASE(OP_GREF) {
xh_entry *e; struct pic_irep *irep = vm_get_irep(pic);
pic_sym *sym;
if ((e = xh_get_int(&pic->globals, c.u.i)) == NULL) { sym = irep->syms[c.u.i];
pic_errorf(pic, "logic flaw; reference to uninitialized global variable: %s", pic_symbol_name(pic, c.u.i)); if (! pic_dict_has(pic, pic->globals, sym)) {
pic_errorf(pic, "logic flaw; reference to uninitialized global variable: %s", pic_symbol_name(pic, sym));
} }
PUSH(xh_val(e, pic_value)); PUSH(pic_dict_ref(pic, pic->globals, sym));
NEXT; NEXT;
} }
CASE(OP_GSET) { CASE(OP_GSET) {
struct pic_irep *irep = vm_get_irep(pic);
pic_sym *sym;
pic_value val; pic_value val;
sym = irep->syms[c.u.i];
val = POP(); val = POP();
xh_put_int(&pic->globals, c.u.i, &val); pic_dict_set(pic, pic->globals, sym, val);
NEXT; NEXT;
} }
CASE(OP_LREF) { CASE(OP_LREF) {
@ -1031,14 +1046,14 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
NEXT; NEXT;
} }
CASE(OP_SYMBOL_P) { CASE(OP_SYMBOLP) {
pic_value p; pic_value p;
p = POP(); p = POP();
PUSH(pic_bool_value(pic_sym_p(p))); PUSH(pic_bool_value(pic_sym_p(p)));
NEXT; NEXT;
} }
CASE(OP_PAIR_P) { CASE(OP_PAIRP) {
pic_value p; pic_value p;
p = POP(); p = POP();
PUSH(pic_bool_value(pic_pair_p(p))); PUSH(pic_bool_value(pic_pair_p(p)));

11
extlib/benz/write.c
View File

@ -11,13 +11,14 @@
#include "picrin/dict.h" #include "picrin/dict.h"
#include "picrin/record.h" #include "picrin/record.h"
#include "picrin/proc.h" #include "picrin/proc.h"
#include "picrin/symbol.h"
static bool static bool
is_tagged(pic_state *pic, pic_sym tag, pic_value pair) is_tagged(pic_state *pic, pic_sym *tag, pic_value pair)
{ {
return pic_pair_p(pic_cdr(pic, pair)) return pic_pair_p(pic_cdr(pic, pair))
&& pic_nil_p(pic_cddr(pic, pair)) && pic_nil_p(pic_cddr(pic, pair))
&& pic_eq_p(pic_car(pic, pair), pic_symbol_value(tag)); && pic_eq_p(pic_car(pic, pair), pic_obj_value(tag));
} }
static bool static bool
@ -175,7 +176,7 @@ write_str(pic_state *pic, struct pic_string *str, xFILE *file)
static void static void
write_record(pic_state *pic, struct pic_record *rec, xFILE *file) write_record(pic_state *pic, struct pic_record *rec, xFILE *file)
{ {
const pic_sym sWRITER = pic_intern_cstr(pic, "writer"); pic_sym *sWRITER = pic_intern_cstr(pic, "writer");
pic_value type, writer, str; pic_value type, writer, str;
#if DEBUG #if DEBUG
@ -265,7 +266,7 @@ write_core(struct writer_control *p, pic_value obj)
xfprintf(file, ")"); xfprintf(file, ")");
break; break;
case PIC_TT_SYMBOL: case PIC_TT_SYMBOL:
xfprintf(file, "%s", pic_symbol_name(pic, pic_sym(obj))); xfprintf(file, "%s", pic_symbol_name(pic, pic_sym_ptr(obj)));
break; break;
case PIC_TT_CHAR: case PIC_TT_CHAR:
if (p->mode == DISPLAY_MODE) { if (p->mode == DISPLAY_MODE) {
@ -332,7 +333,7 @@ write_core(struct writer_control *p, pic_value obj)
case PIC_TT_DICT: case PIC_TT_DICT:
xfprintf(file, "#.(dictionary"); xfprintf(file, "#.(dictionary");
for (it = xh_begin(&pic_dict_ptr(obj)->hash); it != NULL; it = xh_next(it)) { for (it = xh_begin(&pic_dict_ptr(obj)->hash); it != NULL; it = xh_next(it)) {
xfprintf(file, " '%s ", pic_symbol_name(pic, xh_key(it, pic_sym))); xfprintf(file, " '%s ", pic_symbol_name(pic, xh_key(it, pic_sym *)));
write_core(p, xh_val(it, pic_value)); write_core(p, xh_val(it, pic_value));
} }
xfprintf(file, ")"); xfprintf(file, ")");