hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

fixed the bug accessing the wrong context in IVAR and CVAR_M instructions
All checks were successful
continuous-integration/drone/push Build is passing
Details

Browse Source
This commit is contained in:
hyung-hwan 2024-05-31 15:16:31 +09:00
parent c25f0dabdb
commit 75580f5235
9 changed files with 104 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
lib/comp.c
View File

@ -777,9 +777,9 @@ static int emit_double_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1
/* MAKE_FUNCTION is a quad-parameter instruction. /* MAKE_FUNCTION is a quad-parameter instruction.
* The caller must emit two more parameters after the call to this function. * The caller must emit two more parameters after the call to this function.
* however the instruction format is the same up to the second * however the instruction format is the same up to the second
* parameters between MAKE_FUNCTION and MAKE_LAMBDA. * parameters between MAKE_FUNCTION and MAKE_BLOCK.
*/ */
case HCL_CODE_MAKE_LAMBDA: case HCL_CODE_MAKE_BLOCK:
case HCL_CODE_MAKE_FUNCTION: case HCL_CODE_MAKE_FUNCTION:
case HCL_CODE_CALL_R: case HCL_CODE_CALL_R:
case HCL_CODE_SEND_R: case HCL_CODE_SEND_R:
@ -1236,8 +1236,8 @@ static void pop_fnblk (hcl_t* hcl)
{ {
hcl_oow_t attr_mask; hcl_oow_t attr_mask;
/* patch the temporaries mask parameter for the MAKE_LAMBDA or MAKE_FUNCTION instruction */ /* patch the temporaries mask parameter for the MAKE_BLOCK or MAKE_FUNCTION instruction */
HCL_ASSERT (hcl, hcl->code.bc.ptr[fbi->make_inst_pos] == HCL_CODE_MAKE_LAMBDA || HCL_ASSERT (hcl, hcl->code.bc.ptr[fbi->make_inst_pos] == HCL_CODE_MAKE_BLOCK ||
hcl->code.bc.ptr[fbi->make_inst_pos] == HCL_CODE_MAKE_FUNCTION); hcl->code.bc.ptr[fbi->make_inst_pos] == HCL_CODE_MAKE_FUNCTION);
/* the total number of temporaries in this function block must be the sum of /* the total number of temporaries in this function block must be the sum of
@ -1245,7 +1245,7 @@ static void pop_fnblk (hcl_t* hcl)
HCL_ASSERT (hcl, fbi->tmprcnt - hcl->c->tv.wcount == fbi->tmpr_nargs + fbi->tmpr_nrvars + fbi->tmpr_nlvars); HCL_ASSERT (hcl, fbi->tmprcnt - hcl->c->tv.wcount == fbi->tmpr_nargs + fbi->tmpr_nrvars + fbi->tmpr_nlvars);
/* the temporaries mask is a bit-mask that encodes the counts of different temporary variables. /* the temporaries mask is a bit-mask that encodes the counts of different temporary variables.
* and it's split to two intruction parameters when used with MAKE_LAMBDA and MAKE_FUNCTION. * and it's split to two intruction parameters when used with MAKE_BLOCK and MAKE_FUNCTION.
* the INSTA bit is on if fbi->fun_type == FUN_CIM */ * the INSTA bit is on if fbi->fun_type == FUN_CIM */
attr_mask = ENCODE_BLK_MASK(((fbi->fun_type & 0xFF) == FUN_CIM), fbi->tmpr_va, fbi->tmpr_nargs, fbi->tmpr_nrvars, fbi->tmpr_nlvars); attr_mask = ENCODE_BLK_MASK(((fbi->fun_type & 0xFF) == FUN_CIM), fbi->tmpr_va, fbi->tmpr_nargs, fbi->tmpr_nrvars, fbi->tmpr_nlvars);
patch_double_long_params_with_oow (hcl, fbi->make_inst_pos + 1, attr_mask); patch_double_long_params_with_oow (hcl, fbi->make_inst_pos + 1, attr_mask);
@ -3093,8 +3093,8 @@ static int compile_lambda (hcl_t* hcl, hcl_cnode_t* src, int defun)
} }
else else
{ {
/* MAKE_LAMBDA attr_mask_1 attr_mask_2 - will patch attr_mask in pop_fnblk() */ /* MAKE_BLOCK attr_mask_1 attr_mask_2 - will patch attr_mask in pop_fnblk() */
if (emit_double_param_instruction(hcl, HCL_CODE_MAKE_LAMBDA, 0, 0, HCL_CNODE_GET_LOC(cmd)) <= -1) return -1; if (emit_double_param_instruction(hcl, HCL_CODE_MAKE_BLOCK, 0, 0, HCL_CNODE_GET_LOC(cmd)) <= -1) return -1;
} }
HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); /* guaranteed in emit_byte_instruction() */ HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); /* guaranteed in emit_byte_instruction() */
@ -6030,7 +6030,7 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags)
/* keep a virtual function block for the top-level compilation. /* keep a virtual function block for the top-level compilation.
* pass HCL_TYPE_MAX(hcl_oow_t) as make_inst_pos because there is * pass HCL_TYPE_MAX(hcl_oow_t) as make_inst_pos because there is
* no actual MAKE_LAMBDA/MAKE_FUNCTION instruction which otherwise * no actual MAKE_BLOCK/MAKE_FUNCTION instruction which otherwise
* would be patched in pop_fnblk(). */ * would be patched in pop_fnblk(). */
if (push_fnblk( if (push_fnblk(

4
lib/decode.c
View File

@ -716,14 +716,14 @@ int hcl_decode (hcl_t* hcl, const hcl_code_t* code, hcl_oow_t start, hcl_oow_t e
break; break;
} }
case HCL_CODE_MAKE_LAMBDA: case HCL_CODE_MAKE_BLOCK:
/* b1 - block mask /* b1 - block mask
* b2 - block mask */ * b2 - block mask */
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
FETCH_PARAM_CODE_TO (hcl, b2); FETCH_PARAM_CODE_TO (hcl, b2);
b1 = (b1 << (8 * HCL_CODE_LONG_PARAM_SIZE)) | b2; b1 = (b1 << (8 * HCL_CODE_LONG_PARAM_SIZE)) | b2;
LOG_INST_5 (hcl, "make_lambda %zu %zu %zu %zu %zu", LOG_INST_5 (hcl, "make_block %zu %zu %zu %zu %zu",
GET_BLK_MASK_INSTA(b1), GET_BLK_MASK_INSTA(b1),
GET_BLK_MASK_VA(b1), GET_BLK_MASK_VA(b1),
GET_BLK_MASK_NARGS(b1), GET_BLK_MASK_NARGS(b1),

50
lib/exec.c
View File

@ -421,10 +421,11 @@ static HCL_INLINE void fill_function_data (hcl_t* hcl, hcl_oop_function_t func,
func->attr_mask = HCL_SMOOI_TO_OOP(attr_mask); func->attr_mask = HCL_SMOOI_TO_OOP(attr_mask);
} }
static HCL_INLINE hcl_oop_lambda_t make_lambda (hcl_t* hcl) static HCL_INLINE hcl_oop_lambda_t make_block (hcl_t* hcl)
{ {
/* create a base block used for creation of a block context */ /* create a base block used for creation of a block context */
return (hcl_oop_lambda_t)hcl_allocoopobj(hcl, HCL_BRAND_LAMBDA, HCL_BLOCK_NAMED_INSTVARS); /*return (hcl_oop_lambda_t)hcl_allocoopobj(hcl, HCL_BRAND_BLOCK, HCL_BLOCK_NAMED_INSTVARS);*/
return (hcl_oop_function_t)hcl_instantiate(hcl, hcl->c_block, HCL_NULL, 0);
} }
static HCL_INLINE void fill_block_data (hcl_t* hcl, hcl_oop_lambda_t blk, hcl_ooi_t attr_mask, hcl_ooi_t ip, hcl_oop_context_t homectx) static HCL_INLINE void fill_block_data (hcl_t* hcl, hcl_oop_lambda_t blk, hcl_ooi_t attr_mask, hcl_ooi_t ip, hcl_oop_context_t homectx)
@ -1902,7 +1903,7 @@ static int prepare_new_context (hcl_t* hcl, hcl_oop_lambda_t op_blk, hcl_ooi_t n
hcl_ooi_t fixed_nargs, actual_nargs, excess_nargs; hcl_ooi_t fixed_nargs, actual_nargs, excess_nargs;
/* the receiver must be a block context */ /* the receiver must be a block context */
HCL_ASSERT (hcl, HCL_IS_LAMBDA(hcl, op_blk)); HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, op_blk));
attr_mask = HCL_OOP_TO_SMOOI(op_blk->attr_mask); attr_mask = HCL_OOP_TO_SMOOI(op_blk->attr_mask);
@ -1950,13 +1951,16 @@ static int prepare_new_context (hcl_t* hcl, hcl_oop_lambda_t op_blk, hcl_ooi_t n
if (is_msgsend) if (is_msgsend)
{ {
blkctx->home = blkctx; /* itself */ /*blkctx->home = blkctx;*/ /* itself */
blkctx->home = op_blk->home;
blkctx->mthhome = blkctx;
blkctx->receiver = HCL_STACK_GETRCV(hcl, nargs); blkctx->receiver = HCL_STACK_GETRCV(hcl, nargs);
blkctx->ivaroff = HCL_SMOOI_TO_OOP(msg_ivaroff); blkctx->ivaroff = HCL_SMOOI_TO_OOP(msg_ivaroff);
} }
else else
{ {
blkctx->home = op_blk->home; blkctx->home = op_blk->home;
blkctx->mthhome = hcl->_nil;
blkctx->receiver = op_blk->home->receiver; blkctx->receiver = op_blk->home->receiver;
blkctx->ivaroff = HCL_SMOOI_TO_OOP(0); /* not useful if it's not message send */ blkctx->ivaroff = HCL_SMOOI_TO_OOP(0); /* not useful if it's not message send */
} }
@ -1990,7 +1994,7 @@ static HCL_INLINE int __activate_block (hcl_t* hcl, hcl_oop_lambda_t op_blk, hcl
{ {
int x; int x;
HCL_ASSERT (hcl, HCL_IS_LAMBDA(hcl, op_blk)); HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, op_blk));
x = prepare_new_context( x = prepare_new_context(
hcl, hcl,
@ -2017,7 +2021,7 @@ static HCL_INLINE int activate_block (hcl_t* hcl, hcl_ooi_t nargs, hcl_ooi_t nrv
int x; int x;
op_blk = (hcl_oop_lambda_t)HCL_STACK_GETOP(hcl, nargs); op_blk = (hcl_oop_lambda_t)HCL_STACK_GETOP(hcl, nargs);
HCL_ASSERT (hcl, HCL_IS_LAMBDA(hcl, op_blk)); HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, op_blk));
x = __activate_block(hcl, op_blk, nargs, nrvars, 0, 0, &newctx); x = __activate_block(hcl, op_blk, nargs, nrvars, 0, 0, &newctx);
if (HCL_UNLIKELY(x <= -1)) return -1; if (HCL_UNLIKELY(x <= -1)) return -1;
@ -3344,9 +3348,9 @@ static int execute (hcl_t* hcl)
case HCL_CODE_PUSH_IVAR_7: case HCL_CODE_PUSH_IVAR_7:
b1 = bcode & 0x7; /* low 3 bits */ b1 = bcode & 0x7; /* low 3 bits */
push_ivar: push_ivar:
LOG_INST_2 (hcl, "push_ivar %zu ## [%zd]", b1, HCL_OOP_TO_SMOOI(hcl->active_context->home->ivaroff)); LOG_INST_2 (hcl, "push_ivar %zu ## [%zd]", b1, HCL_OOP_TO_SMOOI(hcl->active_context/*->mthhome*/->ivaroff));
HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_TYPE(hcl->active_context->receiver) == HCL_OBJ_TYPE_OOP); HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_TYPE(hcl->active_context->receiver) == HCL_OBJ_TYPE_OOP);
b1 += HCL_OOP_TO_SMOOI(hcl->active_context->home->ivaroff); b1 += HCL_OOP_TO_SMOOI(hcl->active_context/*->mthhome*/->ivaroff);
HCL_STACK_PUSH (hcl, ((hcl_oop_oop_t)hcl->active_context->receiver)->slot[b1]); HCL_STACK_PUSH (hcl, ((hcl_oop_oop_t)hcl->active_context->receiver)->slot[b1]);
break; break;
@ -3365,9 +3369,9 @@ static int execute (hcl_t* hcl)
case HCL_CODE_STORE_INTO_IVAR_7: case HCL_CODE_STORE_INTO_IVAR_7:
b1 = bcode & 0x7; /* low 3 bits */ b1 = bcode & 0x7; /* low 3 bits */
store_instvar: store_instvar:
LOG_INST_2 (hcl, "store_into_ivar %zu ## [%zd]", b1, HCL_OOP_TO_SMOOI(hcl->active_context->home->ivaroff)); LOG_INST_2 (hcl, "store_into_ivar %zu ## [%zd]", b1, HCL_OOP_TO_SMOOI(hcl->active_context/*->mthhome*/->ivaroff));
HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_TYPE(hcl->active_context->receiver) == HCL_OBJ_TYPE_OOP); HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_TYPE(hcl->active_context->receiver) == HCL_OBJ_TYPE_OOP);
b1 += HCL_OOP_TO_SMOOI(hcl->active_context->home->ivaroff); b1 += HCL_OOP_TO_SMOOI(hcl->active_context/*->mthhome*/->ivaroff);
((hcl_oop_oop_t)hcl->active_context->receiver)->slot[b1] = HCL_STACK_GETTOP(hcl); ((hcl_oop_oop_t)hcl->active_context->receiver)->slot[b1] = HCL_STACK_GETTOP(hcl);
break; break;
@ -3692,7 +3696,7 @@ static int execute (hcl_t* hcl)
LOG_INST_2 (hcl, "call %zu %zu", b1, b2); LOG_INST_2 (hcl, "call %zu %zu", b1, b2);
rcv = HCL_STACK_GETOP(hcl, b1); rcv = HCL_STACK_GETOP(hcl, b1);
if (HCL_IS_LAMBDA(hcl, rcv)) if (HCL_IS_BLOCK(hcl, rcv))
{ {
if (activate_block(hcl, b1, b2) <= -1) goto call2_failed; if (activate_block(hcl, b1, b2) <= -1) goto call2_failed;
break; break;
@ -3733,7 +3737,7 @@ static int execute (hcl_t* hcl)
if (activate_function(hcl, b1) <= -1) goto call_failed; if (activate_function(hcl, b1) <= -1) goto call_failed;
break; break;
case HCL_BRAND_LAMBDA: case HCL_BRAND_BLOCK:
if (activate_block(hcl, b1, 0) <= -1) goto call_failed; if (activate_block(hcl, b1, 0) <= -1) goto call_failed;
break; break;
@ -3913,7 +3917,7 @@ static int execute (hcl_t* hcl)
hcl_oop_t mdic, cons, blk, car, cdr, name; hcl_oop_t mdic, cons, blk, car, cdr, name;
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_2 (hcl, "class_%hsmstore %zu", (bcode == HCL_CODE_CLASS_CMSTORE? "c": (bcode == HCL_CODE_CLASS_CIMSTORE? "ci": "i")), b1); LOG_INST_2 (hcl, "class_%hsmstore @%zu", (bcode == HCL_CODE_CLASS_CMSTORE? "c": (bcode == HCL_CODE_CLASS_CIMSTORE? "ci": "i")), b1);
/* store the stack top in the member dictionary of the currect class with the key indicated by 'b1' */ /* store the stack top in the member dictionary of the currect class with the key indicated by 'b1' */
@ -4198,8 +4202,8 @@ static int execute (hcl_t* hcl)
hcl_oop_t t; hcl_oop_t t;
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "push_cvar_m %zu", b1); LOG_INST_1 (hcl, "push_cvar_m %zu", b1);
HCL_ASSERT (hcl, (hcl_oop_t)hcl->active_context->home != hcl->_nil); HCL_ASSERT (hcl, (hcl_oop_t)hcl->active_context/*->mthhome*/ != hcl->_nil);
t = hcl->active_context->home->owner; t = hcl->active_context/*->mthhome*/->owner;
if (HCL_UNLIKELY(!HCL_IS_CLASS(hcl, t))) if (HCL_UNLIKELY(!HCL_IS_CLASS(hcl, t)))
{ {
/* this is an internal error or the bytecodes are compromised */ /* this is an internal error or the bytecodes are compromised */
@ -4215,8 +4219,8 @@ static int execute (hcl_t* hcl)
hcl_oop_t t; hcl_oop_t t;
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "store_into_cvar_m %zu", b1); LOG_INST_1 (hcl, "store_into_cvar_m %zu", b1);
HCL_ASSERT (hcl, (hcl_oop_t)hcl->active_context->home != hcl->_nil); HCL_ASSERT (hcl, (hcl_oop_t)hcl->active_context/*->mthhome*/ != hcl->_nil);
t = hcl->active_context->home->owner; t = hcl->active_context/*->mthhome*/->owner;
if (HCL_UNLIKELY(!HCL_IS_CLASS(hcl, t))) if (HCL_UNLIKELY(!HCL_IS_CLASS(hcl, t)))
{ {
/* this is an internal error or the bytecodes are compromised */ /* this is an internal error or the bytecodes are compromised */
@ -4232,8 +4236,8 @@ static int execute (hcl_t* hcl)
hcl_oop_t t; hcl_oop_t t;
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "pop_into_cvar_m %zu", b1); LOG_INST_1 (hcl, "pop_into_cvar_m %zu", b1);
HCL_ASSERT (hcl, (hcl_oop_t)hcl->active_context->home != hcl->_nil); HCL_ASSERT (hcl, (hcl_oop_t)hcl->active_context/*->mthhome*/ != hcl->_nil);
t = hcl->active_context->home->owner; t = hcl->active_context/*->mthhome*/->owner;
if (HCL_UNLIKELY(!HCL_IS_CLASS(hcl, t))) if (HCL_UNLIKELY(!HCL_IS_CLASS(hcl, t)))
{ {
/* this is an internal error or the bytecodes are compromised */ /* this is an internal error or the bytecodes are compromised */
@ -4643,7 +4647,7 @@ static int execute (hcl_t* hcl)
break; break;
} }
case HCL_CODE_MAKE_LAMBDA: case HCL_CODE_MAKE_BLOCK:
{ {
hcl_oop_lambda_t blkobj; hcl_oop_lambda_t blkobj;
@ -4652,7 +4656,7 @@ static int execute (hcl_t* hcl)
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
FETCH_PARAM_CODE_TO (hcl, b2); FETCH_PARAM_CODE_TO (hcl, b2);
b1 = (b1 << (8 * HCL_CODE_LONG_PARAM_SIZE)) | b2; b1 = (b1 << (8 * HCL_CODE_LONG_PARAM_SIZE)) | b2;
LOG_INST_5 (hcl, "make_lambda %zu %zu %zu %zu %zu", LOG_INST_5 (hcl, "make_block %zu %zu %zu %zu %zu",
GET_BLK_MASK_INSTA(b1), GET_BLK_MASK_INSTA(b1),
GET_BLK_MASK_VA(b1), GET_BLK_MASK_VA(b1),
GET_BLK_MASK_NARGS(b1), GET_BLK_MASK_NARGS(b1),
@ -4661,7 +4665,7 @@ static int execute (hcl_t* hcl)
HCL_ASSERT (hcl, b1 >= 0); HCL_ASSERT (hcl, b1 >= 0);
blkobj = make_lambda(hcl); blkobj = make_block(hcl);
if (HCL_UNLIKELY(!blkobj)) goto oops; if (HCL_UNLIKELY(!blkobj)) goto oops;
/* the long forward jump instruction has the format of /* the long forward jump instruction has the format of
@ -4828,7 +4832,7 @@ hcl_pfrc_t hcl_pf_process_fork (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
int x; int x;
blk = (hcl_oop_lambda_t)HCL_STACK_GETARG(hcl, nargs, 0); blk = (hcl_oop_lambda_t)HCL_STACK_GETARG(hcl, nargs, 0);
if (!HCL_IS_LAMBDA(hcl, blk)) if (!HCL_IS_BLOCK(hcl, blk))
{ {
hcl_seterrbfmt (hcl, HCL_EINVAL, "parameter not block - %O", blk); hcl_seterrbfmt (hcl, HCL_EINVAL, "parameter not block - %O", blk);
return HCL_PF_FAILURE; return HCL_PF_FAILURE;

2
lib/gc.c
View File

@ -304,7 +304,7 @@ static kernel_class_info_t kernel_classes[] =
HCL_OFFSETOF(hcl_t, c_prim) }, HCL_OFFSETOF(hcl_t, c_prim) },
#endif #endif
{ "CompiledBlock", 0, { "CompiledBlock", HCL_BRAND_BLOCK,
0, 0,
0, 0,
HCL_BLOCK_NAMED_INSTVARS, HCL_BLOCK_NAMED_INSTVARS,

6
lib/hcl-prv.h
View File

@ -969,13 +969,13 @@ struct hcl_compiler_t
/* hcl_context_t, hcl_lambda_t, hcl_function_t stores the local variable information /* hcl_context_t, hcl_block_t, hcl_function_t stores the local variable information
* *
* Use up to 29 bits in a 32-bit hcl_ooi_t. Exclude the tag bit and the sign bit. * Use up to 29 bits in a 32-bit hcl_ooi_t. Exclude the tag bit and the sign bit.
* | SIGN | INSTA | VA | NARGS | NRVARS | NLVARS | TAG | * | SIGN | INSTA | VA | NARGS | NRVARS | NLVARS | TAG |
* 1 1 8 8 11 2 <= 32 * 1 1 8 8 11 2 <= 32
* ----------------------------------------------------------- * -----------------------------------------------------------
* Parameters to the MAKE_LAMBDA or MAKE_FUNCTION instructions * Parameters to the MAKE_BLOCK or MAKE_FUNCTION instructions
* | INSTA | VA | NARGS | NRVARS | NLVARS * | INSTA | VA | NARGS | NRVARS | NLVARS
* 1 1 4 4 6 <= 16 (HCL_CODE_LONG_PARAM_SIZE 1, two params) * 1 1 4 4 6 <= 16 (HCL_CODE_LONG_PARAM_SIZE 1, two params)
* 1 1 8 8 11 <= 32 (HCL_CODE_LONG_PARAM_SIZE 2, two params, use 29 bits to avoid collection when converted to a smooi) * 1 1 8 8 11 <= 32 (HCL_CODE_LONG_PARAM_SIZE 2, two params, use 29 bits to avoid collection when converted to a smooi)
@ -1371,7 +1371,7 @@ enum hcl_bcode_t
HCL_CODE_RETURN_FROM_BLOCK = 0xFC, /* 252, return the stack top from a block */ HCL_CODE_RETURN_FROM_BLOCK = 0xFC, /* 252, return the stack top from a block */
HCL_CODE_MAKE_FUNCTION = 0xFD, /* 253 */ HCL_CODE_MAKE_FUNCTION = 0xFD, /* 253 */
HCL_CODE_MAKE_LAMBDA = 0xFE, /* 254 */ HCL_CODE_MAKE_BLOCK = 0xFE, /* 254 */
HCL_CODE_NOOP = 0xFF /* 255 */ HCL_CODE_NOOP = 0xFF /* 255 */
}; };

23
lib/hcl.h
View File

@ -578,10 +578,10 @@ typedef struct hcl_function_t hcl_function_t;
typedef struct hcl_function_t* hcl_oop_function_t; typedef struct hcl_function_t* hcl_oop_function_t;
#define HCL_BLOCK_NAMED_INSTVARS 3 #define HCL_BLOCK_NAMED_INSTVARS 3
typedef struct hcl_lambda_t hcl_lambda_t; typedef struct hcl_block_t hcl_block_t;
typedef struct hcl_lambda_t* hcl_oop_lambda_t; typedef struct hcl_block_t* hcl_oop_lambda_t;
#define HCL_CONTEXT_NAMED_INSTVARS 9 #define HCL_CONTEXT_NAMED_INSTVARS 10
typedef struct hcl_context_t hcl_context_t; typedef struct hcl_context_t hcl_context_t;
typedef struct hcl_context_t* hcl_oop_context_t; typedef struct hcl_context_t* hcl_oop_context_t;
@ -603,10 +603,10 @@ struct hcl_function_t
}; };
/* hcl_function_t copies the byte codes and literal frames into itself /* hcl_function_t copies the byte codes and literal frames into itself
* hlc_lambda_t contains minimal information(ip) for referening byte codes * hcl_block_t contains minimal information(ip) for referening byte codes
* and literal frames available in home->origin. * and literal frames available in home->origin. it represents the compiled block.
*/ */
struct hcl_lambda_t struct hcl_block_t
{ {
HCL_OBJ_HEADER; HCL_OBJ_HEADER;
@ -646,13 +646,16 @@ struct hcl_context_t
* points to a function object */ * points to a function object */
hcl_oop_t receiver; hcl_oop_t receiver;
/* it is set to itself for a method context. /* for a block context, it points to the active context at the
* for a block context, it points to the active context at the
* moment the block context was created. that is, it points to * moment the block context was created. that is, it points to
* a method context where the base block has been defined. * a method context where the base block has been defined.
* an activated block context copies this field from the base block context. */ * an activated block context copies this field from the base block context. */
hcl_oop_context_t home; /* context or nil */ hcl_oop_context_t home; /* context or nil */
/* it is set to itself for a method context, nil for other contexts.
* TODO: this field may not be needed.. mthhome access has been commented out.. so remove this field */
hcl_oop_context_t mthhome;
/* instance variable access instructions hold the index to a variable within /* instance variable access instructions hold the index to a variable within
* the the containing class. If the class inherits from a superclass and the * the the containing class. If the class inherits from a superclass and the
* superclass chain contains instance variables, the actual index must be * superclass chain contains instance variables, the actual index must be
@ -2005,7 +2008,7 @@ enum hcl_brand_t
HCL_BRAND_PRIM, HCL_BRAND_PRIM,
HCL_BRAND_FUNCTION, HCL_BRAND_FUNCTION,
HCL_BRAND_LAMBDA, HCL_BRAND_BLOCK,
HCL_BRAND_CONTEXT, HCL_BRAND_CONTEXT,
HCL_BRAND_PROCESS, HCL_BRAND_PROCESS,
HCL_BRAND_PROCESS_SCHEDULER, HCL_BRAND_PROCESS_SCHEDULER,
@ -2076,7 +2079,7 @@ typedef enum hcl_concode_t hcl_concode_t;
#define HCL_IS_SYMBOL(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL) #define HCL_IS_SYMBOL(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL)
#define HCL_IS_CONTEXT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONTEXT) #define HCL_IS_CONTEXT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONTEXT)
#define HCL_IS_FUNCTION(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_FUNCTION) #define HCL_IS_FUNCTION(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_FUNCTION)
#define HCL_IS_LAMBDA(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_LAMBDA) #define HCL_IS_BLOCK(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_BLOCK)
#define HCL_IS_CLASS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CLASS) #define HCL_IS_CLASS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CLASS)
#define HCL_IS_INSTANCE(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_INSTANCE) #define HCL_IS_INSTANCE(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_INSTANCE)
#define HCL_IS_PROCESS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PROCESS) #define HCL_IS_PROCESS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PROCESS)

8
lib/prim.c
View File

@ -699,11 +699,11 @@ static hcl_pfrc_t pf_is_dictionary (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
return HCL_PF_SUCCESS; return HCL_PF_SUCCESS;
} }
static hcl_pfrc_t pf_is_lambda (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs) static hcl_pfrc_t pf_is_block (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
{ {
hcl_oop_t rv, x; hcl_oop_t rv, x;
x = HCL_STACK_GETARG(hcl, nargs, 0); x = HCL_STACK_GETARG(hcl, nargs, 0);
rv = (HCL_IS_LAMBDA(hcl, x))? hcl->_true: hcl->_false; rv = (HCL_IS_BLOCK(hcl, x))? hcl->_true: hcl->_false;
HCL_STACK_SETRET (hcl, nargs, rv); HCL_STACK_SETRET (hcl, nargs, rv);
return HCL_PF_SUCCESS; return HCL_PF_SUCCESS;
} }
@ -1261,8 +1261,8 @@ static pf_t builtin_prims[] =
{ 1, 1, pf_is_array, 6, { 'a','r','r','a','y','?' } }, { 1, 1, pf_is_array, 6, { 'a','r','r','a','y','?' } },
{ 1, 1, pf_is_bytearray, 10, { 'b','y','t','e','a','r','r','a','y','?' } }, { 1, 1, pf_is_bytearray, 10, { 'b','y','t','e','a','r','r','a','y','?' } },
{ 1, 1, pf_is_dictionary, 11, { 'd','i','c','t','i','o','n','a','r','y','?' } }, { 1, 1, pf_is_dictionary, 11, { 'd','i','c','t','i','o','n','a','r','y','?' } },
{ 1, 1, pf_is_lambda, 7, { 'l','a','m','b','d','a','?' } }, { 1, 1, pf_is_block, 7, { 'l','a','m','b','d','a','?' } },
{ 1, 1, pf_is_lambda, 4, { 'f','u','n','?' } }, { 1, 1, pf_is_block, 4, { 'f','u','n','?' } },
{ 1, 1, pf_is_class, 6, { 'c','l','a','s','s','?' } }, { 1, 1, pf_is_class, 6, { 'c','l','a','s','s','?' } },
{ 1, 1, pf_is_object, 7, { 'o','b','j','e','c','t','?' } }, { 1, 1, pf_is_object, 7, { 'o','b','j','e','c','t','?' } },

8
lib/print.c
View File

@ -85,7 +85,7 @@ enum
WORD_PRIM, WORD_PRIM,
WORD_FUNCTION, WORD_FUNCTION,
WORD_LAMBDA, WORD_BLOCK,
WORD_CONTEXT, WORD_CONTEXT,
WORD_PROCESS, WORD_PROCESS,
WORD_PROCESS_SCHEDULER, WORD_PROCESS_SCHEDULER,
@ -110,7 +110,7 @@ static struct
{ 7, { '#','<','P','R','I','M','>' } }, { 7, { '#','<','P','R','I','M','>' } },
{ 11, { '#','<','F','U','N','C','T','I','O','N','>' } }, { 11, { '#','<','F','U','N','C','T','I','O','N','>' } },
{ 9, { '#','<','L','A','M','B','D','A','>' } }, { 8, { '#','<','B','L','O','C','K','>' } },
{ 10, { '#','<','C','O','N','T','E','X','T','>' } }, { 10, { '#','<','C','O','N','T','E','X','T','>' } },
{ 10, { '#','<','P','R','O','C','E','S','S','>' } }, { 10, { '#','<','P','R','O','C','E','S','S','>' } },
{ 20, { '#','<','P','R','O','C','E','S','S','-','S','C','H','E','D','U','L','E','R','>' } }, { 20, { '#','<','P','R','O','C','E','S','S','-','S','C','H','E','D','U','L','E','R','>' } },
@ -667,8 +667,8 @@ next:
word_index = WORD_FUNCTION; word_index = WORD_FUNCTION;
goto print_word; goto print_word;
case HCL_BRAND_LAMBDA: case HCL_BRAND_BLOCK:
word_index = WORD_LAMBDA; word_index = WORD_BLOCK;
goto print_word; goto print_word;
case HCL_BRAND_CONTEXT: case HCL_BRAND_CONTEXT:

41
t/insta-02.hcl
View File

@ -51,3 +51,44 @@ else { printf "OK: value is %d\n" v }
v := ((a:y) 20); v := ((a:y) 20);
if (nqv? v 21) { printf "ERROR: v is not 21\n" } \ if (nqv? v 21) { printf "ERROR: v is not 21\n" } \
else { printf "OK: value is %d\n" v } else { printf "OK: value is %d\n" v }
## --------------------------------------------------------------
class F | j t | {
}
class X | a b c | {
fun :* new () {
self.a := 20
return self
}
fun getA() { return self.a }
fun make(t a b) {
| v |
v := 50
if (t > 5) {
fun X:get_j() { return (((1 + t) + a) + b) }
} else {
fun X:get_j() { return ((2 * (t + a)) + b) }
}
return self
}
}
fun X:get_a() {
return (self:getA)
}
v := ((X:new):get_a)
if (nqv? v 20) { printf "ERROR: v is not 20 - %d\n" v } \
else { printf "OK: value is %d\n" v }
v := (((X:new):make 5 6 7):get_j)
if (nqv? v 29) { printf "ERROR: v is not 29 - %d\n" v } \
else { printf "OK: value is %d\n" v }
v := (((X:new):make 6 6 7):get_j)
if (nqv? v 20) { printf "ERROR: v is not 20 - %d\n" v } \
else { printf "OK: value is %d\n" v }