[bugfix] (set! symbol? list) doesn't work
This commit is contained in:
parent
e6719a43bb
commit
f210efd066
|
@ -533,6 +533,27 @@ gc_mark_global_symbols(pic_state *pic)
|
|||
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
|
||||
gc_mark_phase(pic_state *pic)
|
||||
{
|
||||
|
@ -573,6 +594,9 @@ gc_mark_phase(pic_state *pic)
|
|||
/* mark reserved symbols */
|
||||
gc_mark_global_symbols(pic);
|
||||
|
||||
/* mark system procedures */
|
||||
gc_mark_system_procedures(pic);
|
||||
|
||||
/* global variables */
|
||||
if (pic->globals) {
|
||||
gc_mark_object(pic, (struct pic_object *)pic->globals);
|
||||
|
|
|
@ -106,6 +106,9 @@ struct pic_state {
|
|||
pic_sym *uADD, *uSUB, *uMUL, *uDIV, *uEQ, *uLT, *uLE, *uGT, *uGE, *uNOT;
|
||||
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_USER;
|
||||
|
||||
|
|
|
@ -118,6 +118,9 @@ pic_features(pic_state *pic)
|
|||
#define VM(uid, name) \
|
||||
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
|
||||
pic_init_core(pic_state *pic)
|
||||
{
|
||||
|
@ -177,6 +180,21 @@ pic_init_core(pic_state *pic)
|
|||
pic_init_attr(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_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");
|
||||
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 */
|
||||
pic->globals = pic_make_dict(pic);
|
||||
pic->macros = pic_make_dict(pic);
|
||||
|
|
|
@ -839,15 +839,16 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
#define check_args(name, n) do { \
|
||||
if (c.u.i != n + 1) { \
|
||||
goto L_CALL; \
|
||||
} \
|
||||
#define check_condition(name, n) do { \
|
||||
if (! pic_eq_p(pic->p##name, pic_dict_ref(pic, pic->globals, pic->u##name))) \
|
||||
goto L_CALL; \
|
||||
if (c.u.i != n + 1) \
|
||||
goto L_CALL; \
|
||||
} while (0)
|
||||
|
||||
CASE(OP_CONS) {
|
||||
pic_value a, b;
|
||||
check_args("cons", 2);
|
||||
check_condition(CONS, 2);
|
||||
pic_gc_protect(pic, b = POP());
|
||||
pic_gc_protect(pic, a = POP());
|
||||
(void)POP();
|
||||
|
@ -857,7 +858,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
|
|||
}
|
||||
CASE(OP_CAR) {
|
||||
pic_value p;
|
||||
check_args("car", 1);
|
||||
check_condition(CAR, 1);
|
||||
p = POP();
|
||||
(void)POP();
|
||||
PUSH(pic_car(pic, p));
|
||||
|
@ -865,7 +866,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
|
|||
}
|
||||
CASE(OP_CDR) {
|
||||
pic_value p;
|
||||
check_args("cdr", 1);
|
||||
check_condition(CDR, 1);
|
||||
p = POP();
|
||||
(void)POP();
|
||||
PUSH(pic_cdr(pic, p));
|
||||
|
@ -873,7 +874,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
|
|||
}
|
||||
CASE(OP_NILP) {
|
||||
pic_value p;
|
||||
check_args("null?", 1);
|
||||
check_condition(NILP, 1);
|
||||
p = POP();
|
||||
(void)POP();
|
||||
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) {
|
||||
pic_value p;
|
||||
check_args("symbol?", 1);
|
||||
check_condition(SYMBOLP, 1);
|
||||
p = POP();
|
||||
(void)POP();
|
||||
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) {
|
||||
pic_value p;
|
||||
check_args("pair?", 1);
|
||||
check_condition(PAIRP, 1);
|
||||
p = POP();
|
||||
(void)POP();
|
||||
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) {
|
||||
pic_value v;
|
||||
check_args("not", 1);
|
||||
check_condition(NOT, 1);
|
||||
v = pic_false_p(POP()) ? pic_true_value() : pic_false_value();
|
||||
(void)POP();
|
||||
PUSH(v);
|
||||
|
@ -906,7 +907,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
|
|||
|
||||
CASE(OP_ADD) {
|
||||
pic_value a, b;
|
||||
check_args("+", 2);
|
||||
check_condition(ADD, 2);
|
||||
b = POP();
|
||||
a = POP();
|
||||
(void)POP();
|
||||
|
@ -915,7 +916,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
|
|||
}
|
||||
CASE(OP_SUB) {
|
||||
pic_value a, b;
|
||||
check_args("-", 2);
|
||||
check_condition(SUB, 2);
|
||||
b = POP();
|
||||
a = POP();
|
||||
(void)POP();
|
||||
|
@ -924,7 +925,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
|
|||
}
|
||||
CASE(OP_MUL) {
|
||||
pic_value a, b;
|
||||
check_args("*", 2);
|
||||
check_condition(MUL, 2);
|
||||
b = POP();
|
||||
a = POP();
|
||||
(void)POP();
|
||||
|
@ -933,7 +934,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
|
|||
}
|
||||
CASE(OP_DIV) {
|
||||
pic_value a, b;
|
||||
check_args("/", 2);
|
||||
check_condition(DIV, 2);
|
||||
b = POP();
|
||||
a = POP();
|
||||
(void)POP();
|
||||
|
@ -942,7 +943,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
|
|||
}
|
||||
CASE(OP_EQ) {
|
||||
pic_value a, b;
|
||||
check_args("=", 2);
|
||||
check_condition(EQ, 2);
|
||||
b = POP();
|
||||
a = POP();
|
||||
(void)POP();
|
||||
|
@ -951,7 +952,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
|
|||
}
|
||||
CASE(OP_LE) {
|
||||
pic_value a, b;
|
||||
check_args("<", 2);
|
||||
check_condition(LT, 2);
|
||||
b = POP();
|
||||
a = POP();
|
||||
(void)POP();
|
||||
|
@ -960,7 +961,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
|
|||
}
|
||||
CASE(OP_LT) {
|
||||
pic_value a, b;
|
||||
check_args("<=", 2);
|
||||
check_condition(LE, 2);
|
||||
b = POP();
|
||||
a = POP();
|
||||
(void)POP();
|
||||
|
|
|
@ -0,0 +1,13 @@
|
|||
(import (picrin base)
|
||||
(picrin test))
|
||||
|
||||
(test-begin)
|
||||
|
||||
(define orig-cons cons)
|
||||
|
||||
(set! symbol? list)
|
||||
|
||||
(test '(1)
|
||||
(symbol? 1))
|
||||
|
||||
(test-end)
|
Loading…
Reference in New Issue