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

[bugfix] (set! symbol? list) doesn't work

This commit is contained in:
Yuichi Nishiwaki 2015-07-04 18:48:48 +09:00
parent e6719a43bb
commit f210efd066
5 changed files with 93 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
extlib/benz/gc.c
View File

@ -533,6 +533,27 @@ gc_mark_global_symbols(pic_state *pic)
M(uVALUES); M(uCALL_WITH_VALUES); M(uVALUES); M(uCALL_WITH_VALUES);
} }
#define P(x) gc_mark(pic, pic->x)
static void
gc_mark_system_procedures(pic_state *pic)
{
P(pCONS);
P(pCAR);
P(pCDR);
P(pNILP);
P(pSYMBOLP);
P(pPAIRP);
P(pNOT);
P(pADD);
P(pSUB);
P(pMUL);
P(pDIV);
P(pEQ);
P(pLT);
P(pLE);
}
static void static void
gc_mark_phase(pic_state *pic) gc_mark_phase(pic_state *pic)
{ {
@ -573,6 +594,9 @@ gc_mark_phase(pic_state *pic)
/* mark reserved symbols */ /* mark reserved symbols */
gc_mark_global_symbols(pic); gc_mark_global_symbols(pic);
/* mark system procedures */
gc_mark_system_procedures(pic);
/* global variables */ /* global variables */
if (pic->globals) { if (pic->globals) {
gc_mark_object(pic, (struct pic_object *)pic->globals); gc_mark_object(pic, (struct pic_object *)pic->globals);

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

@ -106,6 +106,9 @@ struct pic_state {
pic_sym *uADD, *uSUB, *uMUL, *uDIV, *uEQ, *uLT, *uLE, *uGT, *uGE, *uNOT; pic_sym *uADD, *uSUB, *uMUL, *uDIV, *uEQ, *uLT, *uLE, *uGT, *uGE, *uNOT;
pic_sym *uVALUES, *uCALL_WITH_VALUES; pic_sym *uVALUES, *uCALL_WITH_VALUES;
pic_value pCONS, pCAR, pCDR, pNILP, pPAIRP, pSYMBOLP, pNOT;
pic_value pADD, pSUB, pMUL, pDIV, pEQ, pLT, pLE;
struct pic_lib *PICRIN_BASE; struct pic_lib *PICRIN_BASE;
struct pic_lib *PICRIN_USER; struct pic_lib *PICRIN_USER;

34
extlib/benz/state.c
View File

@ -118,6 +118,9 @@ pic_features(pic_state *pic)
#define VM(uid, name) \ #define VM(uid, name) \
pic_define_syntactic_keyword_(pic, pic->lib->env, pic_intern_cstr(pic, name), uid) pic_define_syntactic_keyword_(pic, pic->lib->env, pic_intern_cstr(pic, name), uid)
#define VM2(proc, name) \
proc = pic_ref(pic, pic->lib, name)
static void static void
pic_init_core(pic_state *pic) pic_init_core(pic_state *pic)
{ {
@ -177,6 +180,21 @@ pic_init_core(pic_state *pic)
pic_init_attr(pic); DONE; pic_init_attr(pic); DONE;
pic_init_reg(pic); DONE; pic_init_reg(pic); DONE;
VM2(pic->pCONS, "cons");
VM2(pic->pCAR, "car");
VM2(pic->pCDR, "cdr");
VM2(pic->pNILP, "null?");
VM2(pic->pSYMBOLP, "symbol?");
VM2(pic->pPAIRP, "pair?");
VM2(pic->pNOT, "not");
VM2(pic->pADD, "+");
VM2(pic->pSUB, "-");
VM2(pic->pMUL, "*");
VM2(pic->pDIV, "/");
VM2(pic->pEQ, "=");
VM2(pic->pLT, "<");
VM2(pic->pLE, "<=");
pic_try { pic_try {
pic_load_cstr(pic, &pic_boot[0][0]); pic_load_cstr(pic, &pic_boot[0][0]);
} }
@ -354,6 +372,22 @@ pic_open(pic_allocf allocf, void *userdata)
U(uCALL_WITH_VALUES, "call-with-values"); U(uCALL_WITH_VALUES, "call-with-values");
pic_gc_arena_restore(pic, ai); pic_gc_arena_restore(pic, ai);
/* system procedures */
pic->pCONS = pic_invalid_value();
pic->pCAR = pic_invalid_value();
pic->pCDR = pic_invalid_value();
pic->pNILP = pic_invalid_value();
pic->pSYMBOLP = pic_invalid_value();
pic->pPAIRP = pic_invalid_value();
pic->pNOT = pic_invalid_value();
pic->pADD = pic_invalid_value();
pic->pSUB = pic_invalid_value();
pic->pMUL = pic_invalid_value();
pic->pDIV = pic_invalid_value();
pic->pEQ = pic_invalid_value();
pic->pLT = pic_invalid_value();
pic->pLE = pic_invalid_value();
/* root tables */ /* root tables */
pic->globals = pic_make_dict(pic); pic->globals = pic_make_dict(pic);
pic->macros = pic_make_dict(pic); pic->macros = pic_make_dict(pic);

37
extlib/benz/vm.c
View File

@ -839,15 +839,16 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
NEXT; NEXT;
} }
#define check_args(name, n) do { \ #define check_condition(name, n) do { \
if (c.u.i != n + 1) { \ if (! pic_eq_p(pic->p##name, pic_dict_ref(pic, pic->globals, pic->u##name))) \
goto L_CALL; \ goto L_CALL; \
} \ if (c.u.i != n + 1) \
goto L_CALL; \
} while (0) } while (0)
CASE(OP_CONS) { CASE(OP_CONS) {
pic_value a, b; pic_value a, b;
check_args("cons", 2); check_condition(CONS, 2);
pic_gc_protect(pic, b = POP()); pic_gc_protect(pic, b = POP());
pic_gc_protect(pic, a = POP()); pic_gc_protect(pic, a = POP());
(void)POP(); (void)POP();
@ -857,7 +858,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
} }
CASE(OP_CAR) { CASE(OP_CAR) {
pic_value p; pic_value p;
check_args("car", 1); check_condition(CAR, 1);
p = POP(); p = POP();
(void)POP(); (void)POP();
PUSH(pic_car(pic, p)); PUSH(pic_car(pic, p));
@ -865,7 +866,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
} }
CASE(OP_CDR) { CASE(OP_CDR) {
pic_value p; pic_value p;
check_args("cdr", 1); check_condition(CDR, 1);
p = POP(); p = POP();
(void)POP(); (void)POP();
PUSH(pic_cdr(pic, p)); PUSH(pic_cdr(pic, p));
@ -873,7 +874,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
} }
CASE(OP_NILP) { CASE(OP_NILP) {
pic_value p; pic_value p;
check_args("null?", 1); check_condition(NILP, 1);
p = POP(); p = POP();
(void)POP(); (void)POP();
PUSH(pic_bool_value(pic_nil_p(p))); PUSH(pic_bool_value(pic_nil_p(p)));
@ -881,7 +882,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
} }
CASE(OP_SYMBOLP) { CASE(OP_SYMBOLP) {
pic_value p; pic_value p;
check_args("symbol?", 1); check_condition(SYMBOLP, 1);
p = POP(); p = POP();
(void)POP(); (void)POP();
PUSH(pic_bool_value(pic_sym_p(p))); PUSH(pic_bool_value(pic_sym_p(p)));
@ -889,7 +890,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
} }
CASE(OP_PAIRP) { CASE(OP_PAIRP) {
pic_value p; pic_value p;
check_args("pair?", 1); check_condition(PAIRP, 1);
p = POP(); p = POP();
(void)POP(); (void)POP();
PUSH(pic_bool_value(pic_pair_p(p))); PUSH(pic_bool_value(pic_pair_p(p)));
@ -897,7 +898,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
} }
CASE(OP_NOT) { CASE(OP_NOT) {
pic_value v; pic_value v;
check_args("not", 1); check_condition(NOT, 1);
v = pic_false_p(POP()) ? pic_true_value() : pic_false_value(); v = pic_false_p(POP()) ? pic_true_value() : pic_false_value();
(void)POP(); (void)POP();
PUSH(v); PUSH(v);
@ -906,7 +907,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
CASE(OP_ADD) { CASE(OP_ADD) {
pic_value a, b; pic_value a, b;
check_args("+", 2); check_condition(ADD, 2);
b = POP(); b = POP();
a = POP(); a = POP();
(void)POP(); (void)POP();
@ -915,7 +916,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
} }
CASE(OP_SUB) { CASE(OP_SUB) {
pic_value a, b; pic_value a, b;
check_args("-", 2); check_condition(SUB, 2);
b = POP(); b = POP();
a = POP(); a = POP();
(void)POP(); (void)POP();
@ -924,7 +925,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
} }
CASE(OP_MUL) { CASE(OP_MUL) {
pic_value a, b; pic_value a, b;
check_args("*", 2); check_condition(MUL, 2);
b = POP(); b = POP();
a = POP(); a = POP();
(void)POP(); (void)POP();
@ -933,7 +934,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
} }
CASE(OP_DIV) { CASE(OP_DIV) {
pic_value a, b; pic_value a, b;
check_args("/", 2); check_condition(DIV, 2);
b = POP(); b = POP();
a = POP(); a = POP();
(void)POP(); (void)POP();
@ -942,7 +943,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
} }
CASE(OP_EQ) { CASE(OP_EQ) {
pic_value a, b; pic_value a, b;
check_args("=", 2); check_condition(EQ, 2);
b = POP(); b = POP();
a = POP(); a = POP();
(void)POP(); (void)POP();
@ -951,7 +952,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
} }
CASE(OP_LE) { CASE(OP_LE) {
pic_value a, b; pic_value a, b;
check_args("<", 2); check_condition(LT, 2);
b = POP(); b = POP();
a = POP(); a = POP();
(void)POP(); (void)POP();
@ -960,7 +961,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
} }
CASE(OP_LT) { CASE(OP_LT) {
pic_value a, b; pic_value a, b;
check_args("<=", 2); check_condition(LE, 2);
b = POP(); b = POP();
a = POP(); a = POP();
(void)POP(); (void)POP();

13
t/override.scm Normal file
View File

@ -0,0 +1,13 @@
(import (picrin base)
(picrin test))
(test-begin)
(define orig-cons cons)
(set! symbol? list)
(test '(1)
(symbol? 1))
(test-end)