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

handled the while loop almost in full

Browse Source
This commit is contained in:
hyung-hwan 2016-10-11 10:29:37 +00:00
parent ad671fb493
commit 0773ecece9
4 changed files with 134 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

152
lib/comp.c
View File

@ -314,7 +314,6 @@ static int emit_double_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1
switch (cmd)
{
case HCL_CODE_STORE_INTO_CTXTEMPVAR_0:
case BCODE_POP_INTO_CTXTEMPVAR_0:
case HCL_CODE_PUSH_CTXTEMPVAR_0:
@ -539,11 +538,15 @@ enum
COP_COMPILE_OBJECT,
COP_COMPILE_OBJECT_LIST,
COP_COMPILE_ARGUMENT_LIST,
COP_EMIT_POP,
COP_EMIT_CALL,
COP_EMIT_LAMBDA,
COP_EMIT_POP,
COP_EMIT_RETURN,
COP_EMIT_SET
COP_EMIT_SET,
COP_POST_WHILE_BODY,
COP_POST_WHILE_COND
};
/* ========================================================================= */
@ -847,6 +850,7 @@ static int compile_while (hcl_t* hcl, hcl_oop_t src)
/* (while (xxxx) ... ) */
hcl_oop_t obj, cond;
hcl_oow_t cond_pos;
hcl_cframe_t* cf;
obj = HCL_CONS_CDR(src);
@ -869,24 +873,12 @@ static int compile_while (hcl_t* hcl, hcl_oop_t src)
cond_pos = hcl->code.bc.len;
cond = HCL_CONS_CAR(obj);
obj = HCL_CONS_CDR(obj);
if (!HCL_IS_NIL(hcl, obj))
{
HCL_DEBUG1 (hcl, "Synatx error - too many arguments to return - %O\n", src);
hcl_setsynerr (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL); /* TODO: error location */
return -1;
}
/* specifying MAX_CODE_JUMP causes emit_single_param_instruction() to
* produce the long jump instruction (BCODE_JUMP_FORWARD_X) */
if (emit_single_param_instruction (hcl, HCL_CODE_JUMP_FORWARD_0, MAX_CODE_JUMP) <= -1) return -1;
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_LIST, obj);
HCL_ASSERT (cond_pos < HCL_SMOOI_MAX); /* guaranteed in emit_byte_instruction() */
PUSH_SUBCFRAME (hcl, COP_EMIT_LAMBDA, HCL_SMOOI_TO_OOP(cond_pos));
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, cond); /* 1 */
PUSH_SUBCFRAME (hcl, COP_POST_WHILE_COND, obj); /* 2 */
cf = GET_SUBCFRAME (hcl);
cf->u.post_while.cond_pos = cond_pos;
return 0;
}
@ -1166,6 +1158,94 @@ static int compile_object_list (hcl_t* hcl)
return 0;
}
/* ========================================================================= */
static HCL_INLINE int post_while_cond (hcl_t* hcl)
{
hcl_cframe_t* cf;
hcl_oow_t jump_inst_pos;
hcl_ooi_t cond_pos;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (cf->opcode == COP_POST_WHILE_COND);
cond_pos = cf->u.post_while.cond_pos;
jump_inst_pos = hcl->code.bc.len;
HCL_ASSERT (jump_inst_pos < HCL_SMOOI_MAX);
if (emit_single_param_instruction (hcl, HCL_CODE_JUMP_FORWARD_IF_FALSE_0, MAX_CODE_JUMP) <= -1) return -1;
if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP) <= -1) return -1;
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_LIST, cf->operand); /* 1 */
PUSH_SUBCFRAME (hcl, COP_POST_WHILE_BODY, HCL_SMOOI_TO_OOP(jump_inst_pos)); /* 2 */
cf = GET_SUBCFRAME(hcl);
cf->u.post_while.cond_pos = cond_pos;
return 0;
}
static HCL_INLINE int post_while_body (hcl_t* hcl)
{
hcl_cframe_t* cf;
hcl_ooi_t jip;
hcl_oow_t jump_offset, body_size;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (cf->opcode == COP_POST_WHILE_BODY);
HCL_ASSERT (HCL_OOP_IS_SMOOI(cf->operand));
HCL_ASSERT (hcl->code.bc.len >= cf->u.post_while.cond_pos);
if (hcl->code.bc.len > cf->u.post_while.cond_pos)
{
hcl_ooi_t offset;
if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP) <= -1) return -1;
offset = hcl->code.bc.len - cf->u.post_while.cond_pos + 1;
if (offset > 3) offset += HCL_BCODE_LONG_PARAM_SIZE;
if (emit_single_param_instruction (hcl, HCL_CODE_JUMP_BACKWARD_0, offset) <= -1) return -1;
}
jip = HCL_OOP_TO_SMOOI(cf->operand);
/* HCL_CODE_LONG_PARAM_SIZE + 1 => size of the long JUMP_FORWARD_IF_FALSE_X instruction */
body_size = hcl->code.bc.len - jip - (HCL_BCODE_LONG_PARAM_SIZE + 1);
if (body_size > MAX_CODE_JUMP)
{
/* switch to JUMP2 instruction to allow a bigger jump offset.
* up to twice MAX_CODE_JUMP only */
/* TODO:.... patch_instruction (hcl, jip, HCL_CODE_JUMP2_FORWARD_IF_FALSE); */
jump_offset = body_size - MAX_CODE_JUMP;
}
else
{
jump_offset = body_size;
}
#if (HCL_BCODE_LONG_PARAM_SIZE == 2)
patch_instruction (hcl, jip + 1, jump_offset >> 8);
patch_instruction (hcl, jip + 2, jump_offset & 0xFF);
#else
patch_instruction (hcl, jip + 1, jump_offset);
#endif
POP_CFRAME (hcl);
return 0;
}
/* ========================================================================= */
static HCL_INLINE int emit_call (hcl_t* hcl)
{
hcl_cframe_t* cf;
int n;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (cf->opcode == COP_EMIT_CALL);
HCL_ASSERT (HCL_OOP_IS_SMOOI(cf->operand));
n = emit_single_param_instruction (hcl, HCL_CODE_CALL_0, HCL_OOP_TO_SMOOI(cf->operand));
POP_CFRAME (hcl);
return n;
}
static HCL_INLINE int emit_lambda (hcl_t* hcl)
{
hcl_cframe_t* cf;
@ -1244,20 +1324,6 @@ static HCL_INLINE int emit_pop (hcl_t* hcl)
return n;
}
static HCL_INLINE int emit_call (hcl_t* hcl)
{
hcl_cframe_t* cf;
int n;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (cf->opcode == COP_EMIT_CALL);
HCL_ASSERT (HCL_OOP_IS_SMOOI(cf->operand));
n = emit_single_param_instruction (hcl, HCL_CODE_CALL_0, HCL_OOP_TO_SMOOI(cf->operand));
POP_CFRAME (hcl);
return n;
}
static HCL_INLINE int emit_return (hcl_t* hcl)
{
@ -1313,6 +1379,9 @@ static HCL_INLINE int emit_set (hcl_t* hcl)
return 0;
}
/* ========================================================================= */
int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
{
hcl_oow_t saved_bc_len, saved_lit_len;
@ -1348,10 +1417,6 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
if (compile_object_list (hcl) <= -1) goto oops;
break;
case COP_EMIT_POP:
if (emit_pop (hcl) <= -1) goto oops;
break;
case COP_EMIT_CALL:
if (emit_call (hcl) <= -1) goto oops;
break;
@ -1360,6 +1425,10 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
if (emit_lambda (hcl) <= -1) goto oops;
break;
case COP_EMIT_POP:
if (emit_pop (hcl) <= -1) goto oops;
break;
case COP_EMIT_RETURN:
if (emit_return (hcl) <= -1) goto oops;
break;
@ -1368,7 +1437,16 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
if (emit_set (hcl) <= -1) goto oops;
break;
case COP_POST_WHILE_COND:
if (post_while_cond (hcl) <= -1) goto oops;
break;
case COP_POST_WHILE_BODY:
if (post_while_body (hcl) <= -1) goto oops;
break;
default:
HCL_DEBUG1 (hcl, "Internal error - invalid compiler opcode %d\n", cf->opcode);
hcl->errnum = HCL_EINTERN;
goto oops;
}

20
lib/exec.c
View File

@ -1100,7 +1100,6 @@ static int execute (hcl_t* hcl)
while (1)
{
if (hcl->sem_heap_count > 0)
{
hcl_ntime_t ft, now;
@ -1487,7 +1486,7 @@ static int execute (hcl_t* hcl)
case HCL_CODE_JUMP_BACKWARD_X:
FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "jump_backward %zu", b1);
hcl->ip += b1;
hcl->ip -= b1;
break;
case HCL_CODE_JUMP_BACKWARD_0:
@ -1499,18 +1498,27 @@ static int execute (hcl_t* hcl)
break;
case BCODE_JUMP_IF_TRUE_X:
case HCL_CODE_JUMP_FORWARD_IF_FALSE_X:
case BCODE_JUMP_IF_TRUE_0:
case BCODE_JUMP_IF_TRUE_1:
case BCODE_JUMP_IF_TRUE_2:
case BCODE_JUMP_IF_TRUE_3:
HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_FATAL, "<<<<<<<<<<<<<< JUMP NOT IMPLEMENTED YET >>>>>>>>>>>>\n");
hcl->errnum = HCL_ENOIMPL;
return -1;
case HCL_CODE_JUMP_FORWARD_IF_FALSE_X:
FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "jump_forward_if_false %zu", b1);
if (HCL_STACK_GETTOP(hcl) == hcl->_false) hcl->ip += b1;
break;
case HCL_CODE_JUMP_FORWARD_IF_FALSE_0:
case HCL_CODE_JUMP_FORWARD_IF_FALSE_1:
case HCL_CODE_JUMP_FORWARD_IF_FALSE_2:
case HCL_CODE_JUMP_FORWARD_IF_FALSE_3:
HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_FATAL, "<<<<<<<<<<<<<< JUMP NOT IMPLEMENTED YET >>>>>>>>>>>>\n");
hcl->errnum = HCL_ENOIMPL;
return -1;
LOG_INST_1 (hcl, "jump_forward_if_false %zu", (hcl_oow_t)(bcode & 0x3));
if (HCL_STACK_GETTOP(hcl) == hcl->_false) hcl->ip += (bcode & 0x3); /* low 2 bits */
break;
case HCL_CODE_JUMP2_FORWARD:
FETCH_PARAM_CODE_TO (hcl, b1);

5
lib/hcl-prv.h
View File

@ -288,6 +288,11 @@ struct hcl_cframe_t
{
int var_type;
} set;
struct
{
hcl_ooi_t cond_pos;
} post_while;
} u;
};

1
lib/hcl.h
View File

@ -850,7 +850,6 @@ struct hcl_t
hcl_oop_t _large_negative_integer; /* LargeNegativeInteger */
/* == NEVER CHANGE THE ORDER OF FIELDS ABOVE == */
hcl_oop_set_t symtab; /* system-wide symbol table. */
hcl_oop_set_t sysdic; /* system dictionary. */
hcl_oop_process_scheduler_t processor; /* instance of ProcessScheduler */