diff --git a/bin/main.c b/bin/main.c index acd50f8..79c1e31 100644 --- a/bin/main.c +++ b/bin/main.c @@ -1160,6 +1160,7 @@ hcl_logufmt (hcl, HCL_LOG_WARN, fmt, ustr, 0x6789); } #endif +#if 1 if (xtn->reader_istty) { hcl_bitmask_t trait; @@ -1174,6 +1175,7 @@ else trait |= HCL_TRAIT_INTERACTIVE; hcl_setoption (hcl, HCL_TRAIT, &trait); } +#endif while (1) { diff --git a/lib/comp.c b/lib/comp.c index 69c0c2e..3da8bb2 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -86,7 +86,7 @@ static int add_literal (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t* index) /* this removes redundancy of symbols, characters, and integers. */ if (((hcl_oop_oop_t)hcl->code.lit.arr)->slot[i] == obj) { - *index = i; + *index = i - lfbase; return i; } } @@ -1070,7 +1070,7 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src, int defun) /* make_function nargs ntmprs lfbase lfsize */ if (emit_double_param_instruction(hcl, HCL_CODE_MAKE_FUNCTION, nargs, ntmprs) <= -1) return -1; lfbase_pos = hcl->code.bc.len; - if (emit_long_param(hcl, hcl->code.lit.len) <= -1) return -1; /* lfbase */ + if (emit_long_param(hcl, hcl->code.lit.len - hcl->c->blk.info[hcl->c->blk.depth - 1].lfbase) <= -1) return -1; /* lfbase */ lfsize_pos = hcl->code.bc.len; if (emit_long_param(hcl, 0) <= -1) return -1; } @@ -1637,7 +1637,6 @@ static HCL_INLINE int compile_symbol (hcl_t* hcl, hcl_oop_t obj) if (add_literal(hcl, cons, &index) <= -1 || emit_single_param_instruction(hcl, HCL_CODE_PUSH_OBJECT_0, index) <= -1) return -1; -HCL_DEBUG5 (hcl, "************* blk depth [%d] %O , index %d lfbase %d lit len %d\n", (int)hcl->c->blk.depth, cons, (int)index, (int)hcl->c->blk.info[hcl->c->blk.depth].lfbase, (int)hcl->code.lit.len); return 0; } @@ -2513,7 +2512,6 @@ static HCL_INLINE int emit_lambda (hcl_t* hcl) hcl_oow_t block_code_size, lfsize; hcl_ooi_t jip; -HCL_DEBUG1 (hcl, "emit_lambda depth %d\n", (int)hcl->c->blk.depth); cf = GET_TOP_CFRAME(hcl); HCL_ASSERT (hcl, cf->opcode == COP_EMIT_LAMBDA); HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); @@ -2600,7 +2598,6 @@ static HCL_INLINE int emit_set (hcl_t* hcl) HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, cf->operand)); -HCL_DEBUG2 (hcl, "emit_set....%O --- %d\n", cf->operand, (int)hcl->c->blk.depth); cons = (hcl_oop_t)hcl_getatsysdic(hcl, cf->operand); if (!cons) { @@ -2646,9 +2643,39 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj) /* TODO: in case i implement all global variables as block arguments at the top level...what should i do? */ - hcl->c->blk.depth++; -HCL_DEBUG2 (hcl, "ENTERING DEPTH %d LIT LEN %d\n", (int)hcl->c->blk.depth, (int)hcl->code.lit.len); - if (store_temporary_variable_count_for_block(hcl, hcl->c->tv.size, hcl->code.lit.len) <= -1) return -1; + hcl->c->blk.depth++; /* this must be 0 here */ + + /* + * In the non-INTERACTIVE mode, the literal frame base doesn't matter. + * Only the initial function object contains the literal frame. + * No other function objects are created. All lambda defintions are + * translated to base context objects instead. + * + * In the INTERACTIVE mode, the literal frame base plays a key role. + * hcl_compile() is called for the top-level expression andthe literal + * frame base can be 0. The means it is ok for a top-level code to + * reference part of the literal frame reserved for a lambda function. + * + * (set b 1) + * (defun set-a(x) (set a x)) + * (set a 2) + * (set-a 4) + * (printf "%d\n" a) + * + * the global literal frame looks like this: + * @0 (b) + * @1 (a) + * @2 (set-a) + * @3 (printf . #) + * @4 "%d\n" + * + * @1 to @2 will be copied to a function object when defun is executed. + * The literal frame of the created function object for set-a looks + * like this + * @0 (a) + * @1 (set-a) + */ + if (store_temporary_variable_count_for_block(hcl, hcl->c->tv.size, 0) <= -1) return -1; PUSH_CFRAME (hcl, COP_COMPILE_OBJECT, obj); diff --git a/lib/decode.c b/lib/decode.c index 98b1fe9..deccc07 100644 --- a/lib/decode.c +++ b/lib/decode.c @@ -566,7 +566,6 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end) HCL_ASSERT (hcl, b1 >= 0); HCL_ASSERT (hcl, b2 >= b1); - HCL_ASSERT (hcl, b4 >= b3); break; case HCL_CODE_MAKE_BLOCK: diff --git a/lib/exec.c b/lib/exec.c index a156512..58237f5 100644 --- a/lib/exec.c +++ b/lib/exec.c @@ -1676,7 +1676,6 @@ static int execute (hcl_t* hcl) LOG_INST_1 (hcl, "push_literal @%zu", b1); /*HCL_STACK_PUSH (hcl, hcl->code.lit.arr->slot[b1]);*/ HCL_STACK_PUSH (hcl, hcl->active_function->literal_frame[b1]); -HCL_DEBUG3 (hcl, "*** push literal %O => %d active_function %p\n", hcl->active_function->literal_frame[b1], b1, hcl->active_function); break; /* ------------------------------------------------- */ @@ -1705,7 +1704,6 @@ HCL_DEBUG3 (hcl, "*** push literal %O => %d active_function %p\n", hcl->activ handle_object: /*ass = hcl->code.lit.arr->slot[b1];*/ ass = (hcl_oop_cons_t)hcl->active_function->literal_frame[b1]; -HCL_DEBUG3 (hcl, "handle object ass => %O => %d active_function %p\n", ass, b1, hcl->active_function); HCL_ASSERT (hcl, HCL_IS_CONS(hcl, ass)); if ((bcode >> 3) & 1) @@ -2343,7 +2341,6 @@ HCL_DEBUG3 (hcl, "handle object ass => %O => %d active_function %p\n", ass, b1 HCL_ASSERT (hcl, b1 >= 0); HCL_ASSERT (hcl, b2 >= b1); - HCL_ASSERT (hcl, b3 >= 0); /* the MAKE_FUNCTION instruction is followed by the long JUMP_FORWARD_X instruction. * i can decode the instruction and get the size of instructions @@ -2354,7 +2351,6 @@ HCL_DEBUG3 (hcl, "handle object ass => %O => %d active_function %p\n", ass, b1 joff = (joff << 8) | hcl->active_code[hcl->ip + 2]; #endif -HCL_DEBUG1(hcl, "**** MAKE FUNCTION joff = %zu\n", joff); /* copy the byte codes from the active context to the new context */ #if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2) func = (hcl_oop_function_t)make_function(hcl, b4, &hcl->active_code[hcl->ip + 3], joff);