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

added some code to handle while

Browse Source
This commit is contained in:
hyung-hwan 2016-10-10 11:36:24 +00:00
parent 36cdf2e062
commit ad671fb493
6 changed files with 274 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

142
lib/comp.c
View File

@ -241,7 +241,7 @@ static int emit_single_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1
case HCL_CODE_JUMP_FORWARD_0:
case HCL_CODE_JUMP_BACKWARD_0:
case BCODE_JUMP_IF_TRUE_0:
case BCODE_JUMP_IF_FALSE_0:
case HCL_CODE_JUMP_FORWARD_IF_FALSE_0:
case HCL_CODE_CALL_0:
if (param_1 < 4)
{
@ -542,11 +542,18 @@ enum
COP_EMIT_POP,
COP_EMIT_CALL,
COP_EMIT_LAMBDA,
COP_EMIT_RETURN,
COP_EMIT_SET
};
/* ========================================================================= */
static int compile_if (hcl_t* hcl, hcl_oop_t src)
{
/* TODO: NOT IMPLEMENTED */
return -1;
}
static int compile_lambda (hcl_t* hcl, hcl_oop_t src)
{
hcl_oop_t obj, args;
@ -702,9 +709,10 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src)
* count of temporaries in the home context */
if (emit_double_param_instruction (hcl, HCL_CODE_MAKE_BLOCK, nargs, hcl->c->tv.size/*ntmprs*/) <= -1) return -1;
jump_inst_pos = hcl->code.bc.len;
/* specifying MAX_CODE_JUMP causes emit_single_param_instruction() to
* produce the long jump instruction (BCODE_JUMP_FORWARD_X) */
jump_inst_pos = hcl->code.bc.len;
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);
@ -715,6 +723,47 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src)
return 0;
}
static int compile_return (hcl_t* hcl, hcl_oop_t src)
{
hcl_oop_t obj, val;
obj = HCL_CONS_CDR(src);
HCL_ASSERT (HCL_BRANDOF(hcl,src) == HCL_BRAND_CONS);
HCL_ASSERT (HCL_CONS_CAR(src) == hcl->_return);
if (HCL_IS_NIL(hcl, obj))
{
/* TODO: should i allow (return)? does it return the last value on the stack? */
/* no value */
HCL_DEBUG1 (hcl, "Syntax error - no value specified in return - %O\n", src);
hcl_setsynerr (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL); /* TODO: error location */
return -1;
}
else if (HCL_BRANDOF(hcl, obj) != HCL_BRAND_CONS)
{
HCL_DEBUG1 (hcl, "Syntax error - redundant cdr in return - %O\n", src);
hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */
return -1;
}
val = 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;
}
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, val);
PUSH_SUBCFRAME (hcl, COP_EMIT_RETURN, hcl->_nil);
return 0;
}
static int compile_set (hcl_t* hcl, hcl_oop_t src)
{
hcl_cframe_t* cf;
@ -793,7 +842,58 @@ static int compile_set (hcl_t* hcl, hcl_oop_t src)
return 0;
}
static int compile_cons (hcl_t* hcl, hcl_oop_t obj)
static int compile_while (hcl_t* hcl, hcl_oop_t src)
{
/* (while (xxxx) ... ) */
hcl_oop_t obj, cond;
hcl_oow_t cond_pos;
obj = HCL_CONS_CDR(src);
HCL_ASSERT (HCL_BRANDOF(hcl,src) == HCL_BRAND_CONS);
HCL_ASSERT (HCL_CONS_CAR(src) == hcl->_while);
if (HCL_IS_NIL(hcl, obj))
{
/* no value */
HCL_DEBUG1 (hcl, "Syntax error - no condition specified in while - %O\n", src);
hcl_setsynerr (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL); /* TODO: error location */
return -1;
}
else if (HCL_BRANDOF(hcl, obj) != HCL_BRAND_CONS)
{
HCL_DEBUG1 (hcl, "Syntax error - redundant cdr in while - %O\n", src);
hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */
return -1;
}
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));
return 0;
}
/* ========================================================================= */
static int compile_cons_expression (hcl_t* hcl, hcl_oop_t obj)
{
hcl_oop_t car;
int syncode;
@ -807,8 +907,11 @@ static int compile_cons (hcl_t* hcl, hcl_oop_t obj)
{
case HCL_SYNCODE_BEGIN:
case HCL_SYNCODE_DEFUN:
/* TODO: not implemented yet */
break;
case HCL_SYNCODE_IF:
/* TODO: */
if (compile_if (hcl, obj) <= -1) return -1;
break;
case HCL_SYNCODE_LAMBDA:
@ -822,6 +925,16 @@ static int compile_cons (hcl_t* hcl, hcl_oop_t obj)
if (compile_set (hcl, obj) <= -1) return -1;
break;
case HCL_SYNCODE_RETURN:
/* (return 10)
* (return (+ 10 20)) */
if (compile_return (hcl, obj) <= -1) return -1;
break;
case HCL_SYNCODE_WHILE:
if (compile_while (hcl, obj) <= -1) return -1;
break;
default:
HCL_DEBUG3 (hcl, "Internal error - unknown syncode %d at %s:%d\n", syncode, __FILE__, __LINE__);
hcl->errnum = HCL_EINTERN;
@ -981,7 +1094,7 @@ static int compile_object (hcl_t* hcl)
goto done;
case HCL_BRAND_CONS:
if (compile_cons (hcl, cf->operand) <= -1) return -1;
if (compile_cons_expression (hcl, cf->operand) <= -1) return -1;
break;
case HCL_BRAND_SYMBOL_ARRAY:
@ -1146,6 +1259,21 @@ static HCL_INLINE int emit_call (hcl_t* hcl)
return n;
}
static HCL_INLINE int emit_return (hcl_t* hcl)
{
hcl_cframe_t* cf;
int n;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (cf->opcode == COP_EMIT_RETURN);
HCL_ASSERT (HCL_IS_NIL(hcl, cf->operand));
n = emit_byte_instruction (hcl, HCL_CODE_RETURN_FROM_BLOCK);
POP_CFRAME (hcl);
return n;
}
static HCL_INLINE int emit_set (hcl_t* hcl)
{
hcl_cframe_t* cf;
@ -1232,6 +1360,10 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
if (emit_lambda (hcl) <= -1) goto oops;
break;
case COP_EMIT_RETURN:
if (emit_return (hcl) <= -1) goto oops;
break;
case COP_EMIT_SET:
if (emit_set (hcl) <= -1) goto oops;
break;

26
lib/decode.c
View File

@ -269,18 +269,28 @@ int hcl_decode (hcl_t* hcl, hcl_ooi_t start, hcl_ooi_t end)
break;
case BCODE_JUMP_IF_TRUE_X:
case BCODE_JUMP_IF_FALSE_X:
FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "jump_if_true %zu", b1);
break;
case BCODE_JUMP_IF_TRUE_0:
case BCODE_JUMP_IF_TRUE_1:
case BCODE_JUMP_IF_TRUE_2:
case BCODE_JUMP_IF_TRUE_3:
case BCODE_JUMP_IF_FALSE_0:
case BCODE_JUMP_IF_FALSE_1:
case BCODE_JUMP_IF_FALSE_2:
case BCODE_JUMP_IF_FALSE_3:
LOG_INST_0 (hcl, "<<<<<<<<<<<<<< JUMP NOT IMPLEMENTED YET >>>>>>>>>>>>");
hcl->errnum = HCL_ENOIMPL;
return -1;
LOG_INST_1 (hcl, "jump_if_true %zu", (hcl_oow_t)(bcode & 0x3)); /* low 2 bits */
break;
case HCL_CODE_JUMP_FORWARD_IF_FALSE_X:
FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "jump_forward_if_false %zu", 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:
LOG_INST_1 (hcl, "jump_forward_if_false %zu", (hcl_oow_t)(bcode & 0x3)); /* low 2 bits */
break;
case HCL_CODE_JUMP2_FORWARD:
FETCH_PARAM_CODE_TO (hcl, b1);

10
lib/exec.c
View File

@ -1499,15 +1499,15 @@ static int execute (hcl_t* hcl)
break;
case BCODE_JUMP_IF_TRUE_X:
case BCODE_JUMP_IF_FALSE_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:
case BCODE_JUMP_IF_FALSE_0:
case BCODE_JUMP_IF_FALSE_1:
case BCODE_JUMP_IF_FALSE_2:
case BCODE_JUMP_IF_FALSE_3:
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;

4
lib/gc.c
View File

@ -39,7 +39,9 @@ static struct
{ 2, { 'i','f' }, HCL_SYNCODE_IF, HCL_OFFSETOF(hcl_t,_if) },
{ 6, { 'l','a','m','b','d','a' }, HCL_SYNCODE_LAMBDA, HCL_OFFSETOF(hcl_t,_lambda) },
{ 5, { 'q','u','o','t','e' }, HCL_SYNCODE_QUOTE, HCL_OFFSETOF(hcl_t,_quote) },
{ 3, { 's', 'e', 't' }, HCL_SYNCODE_SET, HCL_OFFSETOF(hcl_t,_set) }
{ 6, { 'r','e','t','u','r','n'}, HCL_SYNCODE_RETURN, HCL_OFFSETOF(hcl_t,_return) },
{ 3, { 's','e','t' }, HCL_SYNCODE_SET, HCL_OFFSETOF(hcl_t,_set) },
{ 5, { 'w','h','i','l','e' }, HCL_SYNCODE_WHILE, HCL_OFFSETOF(hcl_t,_while) }
};
/* ========================================================================= */

10
lib/hcl-prv.h
View File

@ -565,10 +565,10 @@ enum hcl_bcode_t
BCODE_JUMP_IF_TRUE_2 = 0x4E,
BCODE_JUMP_IF_TRUE_3 = 0x4F,
BCODE_JUMP_IF_FALSE_0 = 0x50, /* 80 */
BCODE_JUMP_IF_FALSE_1 = 0x51, /* 81 */
BCODE_JUMP_IF_FALSE_2 = 0x52, /* 82 */
BCODE_JUMP_IF_FALSE_3 = 0x53, /* 83 */
HCL_CODE_JUMP_FORWARD_IF_FALSE_0 = 0x50, /* 80 */
HCL_CODE_JUMP_FORWARD_IF_FALSE_1 = 0x51, /* 81 */
HCL_CODE_JUMP_FORWARD_IF_FALSE_2 = 0x52, /* 82 */
HCL_CODE_JUMP_FORWARD_IF_FALSE_3 = 0x53, /* 83 */
HCL_CODE_CALL_0 = 0x54, /* 84 */
HCL_CODE_CALL_1 = 0x55, /* 85 */
@ -637,7 +637,7 @@ enum hcl_bcode_t
HCL_CODE_JUMP_FORWARD_X = 0xC4, /* 196 */
HCL_CODE_JUMP_BACKWARD_X = 0xC8, /* 200 */
BCODE_JUMP_IF_TRUE_X = 0xCC, /* 204 */
BCODE_JUMP_IF_FALSE_X = 0xD0, /* 208 */
HCL_CODE_JUMP_FORWARD_IF_FALSE_X = 0xD0, /* 208 */
HCL_CODE_CALL_X = 0xD4, /* 212 */

6
lib/hcl.h
View File

@ -837,7 +837,9 @@ struct hcl_t
hcl_oop_t _if; /* symbol */
hcl_oop_t _lambda; /* symbol */
hcl_oop_t _quote; /* symbol */
hcl_oop_t _return; /* symbol */
hcl_oop_t _set; /* symbol */
hcl_oop_t _while; /* symbol */
/* == NEVER CHANGE THE ORDER OF FIELDS BELOW == */
/* hcl_ignite() assumes this order. make sure to update symnames in ignite_3() */
@ -1022,7 +1024,9 @@ enum
HCL_SYNCODE_IF,
HCL_SYNCODE_LAMBDA,
HCL_SYNCODE_QUOTE,
HCL_SYNCODE_SET
HCL_SYNCODE_RETURN,
HCL_SYNCODE_SET,
HCL_SYNCODE_WHILE
};
struct hcl_cons_t