diff --git a/lib/comp.c b/lib/comp.c index c4a7c49..e44ae26 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -240,8 +240,6 @@ static int emit_single_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1 case BCODE_POP_INTO_OBJECT_0: case HCL_CODE_JUMP_FORWARD_0: case HCL_CODE_JUMP_BACKWARD_0: - case BCODE_JUMP_IF_TRUE_0: - case HCL_CODE_JUMP_FORWARD_IF_FALSE_0: case HCL_CODE_CALL_0: if (param_1 < 4) { @@ -256,6 +254,10 @@ static int emit_single_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1 goto write_long; } + case HCL_CODE_JUMP_FORWARD_IF_TRUE: + case HCL_CODE_JUMP_FORWARD_IF_FALSE: + case HCL_CODE_JUMP2_FORWARD_IF_TRUE: + case HCL_CODE_JUMP2_FORWARD_IF_FALSE: case HCL_CODE_JUMP2_FORWARD: case HCL_CODE_JUMP2_BACKWARD: case HCL_CODE_PUSH_INTLIT: @@ -545,6 +547,8 @@ enum COP_EMIT_RETURN, COP_EMIT_SET, + COP_POST_UNTIL_BODY, + COP_POST_UNTIL_COND, COP_POST_WHILE_BODY, COP_POST_WHILE_COND }; @@ -845,7 +849,7 @@ static int compile_set (hcl_t* hcl, hcl_oop_t src) return 0; } -static int compile_while (hcl_t* hcl, hcl_oop_t src) +static int compile_while (hcl_t* hcl, hcl_oop_t src, int next_cop) { /* (while (xxxx) ... ) */ hcl_oop_t obj, cond; @@ -855,7 +859,8 @@ static int compile_while (hcl_t* hcl, hcl_oop_t src) obj = HCL_CONS_CDR(src); HCL_ASSERT (HCL_BRANDOF(hcl,src) == HCL_BRAND_CONS); - HCL_ASSERT (HCL_CONS_CAR(src) == hcl->_while); + HCL_ASSERT (HCL_CONS_CAR(src) == hcl->_until || HCL_CONS_CAR(src) == hcl->_while); + HCL_ASSERT (next_cop == COP_POST_UNTIL_COND || next_cop == COP_POST_WHILE_COND); if (HCL_IS_NIL(hcl, obj)) { @@ -872,11 +877,13 @@ static int compile_while (hcl_t* hcl, hcl_oop_t src) } cond_pos = hcl->code.bc.len; + HCL_ASSERT (cond_pos < HCL_SMOOI_MAX); + cond = HCL_CONS_CAR(obj); obj = HCL_CONS_CDR(obj); SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, cond); /* 1 */ - PUSH_SUBCFRAME (hcl, COP_POST_WHILE_COND, obj); /* 2 */ + PUSH_SUBCFRAME (hcl, next_cop, obj); /* 2 */ cf = GET_SUBCFRAME (hcl); cf->u.post_while.cond_pos = cond_pos; @@ -923,8 +930,12 @@ static int compile_cons_expression (hcl_t* hcl, hcl_oop_t obj) if (compile_return (hcl, obj) <= -1) return -1; break; + case HCL_SYNCODE_UNTIL: + if (compile_while (hcl, obj, COP_POST_UNTIL_COND) <= -1) return -1; + break; + case HCL_SYNCODE_WHILE: - if (compile_while (hcl, obj) <= -1) return -1; + if (compile_while (hcl, obj, COP_POST_WHILE_COND) <= -1) return -1; break; default: @@ -1164,18 +1175,31 @@ 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; + int jump_inst, next_cop; cf = GET_TOP_CFRAME(hcl); - HCL_ASSERT (cf->opcode == COP_POST_WHILE_COND); + HCL_ASSERT (cf->opcode == COP_POST_UNTIL_COND || 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 (cf->opcode == COP_POST_UNTIL_COND) + { + jump_inst = HCL_CODE_JUMP_FORWARD_IF_TRUE; + next_cop = COP_POST_UNTIL_BODY; + } + else + { + jump_inst = HCL_CODE_JUMP_FORWARD_IF_FALSE; + next_cop = COP_POST_WHILE_BODY; + } + + if (emit_single_param_instruction (hcl, jump_inst, 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 */ + PUSH_SUBCFRAME (hcl, next_cop, HCL_SMOOI_TO_OOP(jump_inst_pos)); /* 2 */ cf = GET_SUBCFRAME(hcl); cf->u.post_while.cond_pos = cond_pos; return 0; @@ -1188,7 +1212,7 @@ static HCL_INLINE int post_while_body (hcl_t* hcl) hcl_oow_t jump_offset, body_size; cf = GET_TOP_CFRAME(hcl); - HCL_ASSERT (cf->opcode == COP_POST_WHILE_BODY); + HCL_ASSERT (cf->opcode == COP_POST_UNTIL_BODY || cf->opcode == COP_POST_WHILE_BODY); HCL_ASSERT (HCL_OOP_IS_SMOOI(cf->operand)); @@ -1203,14 +1227,14 @@ static HCL_INLINE int post_while_body (hcl_t* hcl) } jip = HCL_OOP_TO_SMOOI(cf->operand); - /* HCL_CODE_LONG_PARAM_SIZE + 1 => size of the long JUMP_FORWARD_IF_FALSE_X instruction */ + /* HCL_CODE_LONG_PARAM_SIZE + 1 => size of the long JUMP_FORWARD_IF_FALSE/JUMP_FORWARD_IF_TRUE 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); */ + patch_instruction (hcl, jip, ((cf->opcode == COP_POST_UNTIL_BODY)? HCL_CODE_JUMP2_FORWARD_IF_TRUE: HCL_CODE_JUMP2_FORWARD_IF_FALSE)); jump_offset = body_size - MAX_CODE_JUMP; } else @@ -1437,14 +1461,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_UNTIL_BODY: case COP_POST_WHILE_BODY: if (post_while_body (hcl) <= -1) goto oops; break; + case COP_POST_UNTIL_COND: + case COP_POST_WHILE_COND: + if (post_while_cond (hcl) <= -1) goto oops; + break; + default: HCL_DEBUG1 (hcl, "Internal error - invalid compiler opcode %d\n", cf->opcode); hcl->errnum = HCL_EINTERN; diff --git a/lib/decode.c b/lib/decode.c index 8fcfad2..ef538cc 100644 --- a/lib/decode.c +++ b/lib/decode.c @@ -268,28 +268,24 @@ int hcl_decode (hcl_t* hcl, hcl_ooi_t start, hcl_ooi_t end) LOG_INST_1 (hcl, "jump_backward %zu", (hcl_oow_t)(bcode & 0x3)); /* low 2 bits */ break; - case BCODE_JUMP_IF_TRUE_X: + case HCL_CODE_JUMP_FORWARD_IF_TRUE: FETCH_PARAM_CODE_TO (hcl, b1); - LOG_INST_1 (hcl, "jump_if_true %zu", b1); + LOG_INST_1 (hcl, "jump_forward_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: - LOG_INST_1 (hcl, "jump_if_true %zu", (hcl_oow_t)(bcode & 0x3)); /* low 2 bits */ + case HCL_CODE_JUMP2_FORWARD_IF_TRUE: + FETCH_PARAM_CODE_TO (hcl, b1); + LOG_INST_1 (hcl, "jump2_forward_if_true %zu", b1); break; - case HCL_CODE_JUMP_FORWARD_IF_FALSE_X: + case HCL_CODE_JUMP_FORWARD_IF_FALSE: 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 */ + case HCL_CODE_JUMP2_FORWARD_IF_FALSE: + FETCH_PARAM_CODE_TO (hcl, b1); + LOG_INST_1 (hcl, "jump2_forward_if_false %zu", b1); break; case HCL_CODE_JUMP2_FORWARD: diff --git a/lib/exec.c b/lib/exec.c index a845aba..1dc3ba3 100644 --- a/lib/exec.c +++ b/lib/exec.c @@ -1497,27 +1497,28 @@ static int execute (hcl_t* hcl) hcl->ip -= (bcode & 0x3); /* low 2 bits */ break; - case BCODE_JUMP_IF_TRUE_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_TRUE: + FETCH_PARAM_CODE_TO (hcl, b1); + LOG_INST_1 (hcl, "jump_forward_if_true %zu", b1); + if (HCL_STACK_GETTOP(hcl) == hcl->_true) hcl->ip += b1; + break; - case HCL_CODE_JUMP_FORWARD_IF_FALSE_X: + case HCL_CODE_JUMP2_FORWARD_IF_TRUE: + FETCH_PARAM_CODE_TO (hcl, b1); + LOG_INST_1 (hcl, "jump2_forward_if_true %zu", b1); + if (HCL_STACK_GETTOP(hcl) == hcl->_true) hcl->ip += MAX_CODE_JUMP + b1; + break; + + case HCL_CODE_JUMP_FORWARD_IF_FALSE: 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: - 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 */ + case HCL_CODE_JUMP2_FORWARD_IF_FALSE: + FETCH_PARAM_CODE_TO (hcl, b1); + LOG_INST_1 (hcl, "jump2_forward_if_false %zu", b1); + if (HCL_STACK_GETTOP(hcl) == hcl->_false) hcl->ip += MAX_CODE_JUMP + b1; break; case HCL_CODE_JUMP2_FORWARD: diff --git a/lib/gc.c b/lib/gc.c index 494a362..da26bdd 100644 --- a/lib/gc.c +++ b/lib/gc.c @@ -41,6 +41,7 @@ static struct { 5, { 'q','u','o','t','e' }, HCL_SYNCODE_QUOTE, HCL_OFFSETOF(hcl_t,_quote) }, { 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, { 'u','n','t','i','l' }, HCL_SYNCODE_UNTIL, HCL_OFFSETOF(hcl_t,_until) }, { 5, { 'w','h','i','l','e' }, HCL_SYNCODE_WHILE, HCL_OFFSETOF(hcl_t,_while) } }; diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index a62c9b0..64ca24b 100644 --- a/lib/hcl-prv.h +++ b/lib/hcl-prv.h @@ -436,8 +436,10 @@ SHORT INSTRUCTION CODE LONG INSTRUCTION C 68-71 0100 01XX JUMP_FORWARD 196 1100 0100 XXXXXXXX JUMP_FORWARD_X 72-75 0100 10XX JUMP_BACKWARD 200 1100 1000 XXXXXXXX JUMP_BACKWARD_X -76-79 0100 11XX JUMP_IF_TRUE 204 1100 1100 XXXXXXXX JUMP_IF_TRUE_X -80-83 0101 00XX JUMP_IF_FALSE 208 1101 0000 XXXXXXXX JUMP_IF_FALSE_X +76-79 0100 11XX UNUSED 204 1100 1100 XXXXXXXX JUMP_FORWARD_IF_TRUE + 205 1100 1101 XXXXXXXX JUMP2_FORWARD_IF_TRUE +80-83 0101 00XX UNUSED 208 1101 0000 XXXXXXXX JUMP_FORWARD_IF_FALSE + 209 1101 0001 XXXXXXXX JUMP2_FORWARD_IF_FALSE 84-87 0101 01XX CALL 212 1101 0100 XXXXXXXX CALL_X @@ -560,20 +562,11 @@ enum hcl_bcode_t HCL_CODE_JUMP_FORWARD_2 = 0x46, /* 70 */ HCL_CODE_JUMP_FORWARD_3 = 0x47, /* 71 */ - HCL_CODE_JUMP_BACKWARD_0 = 0x48, - HCL_CODE_JUMP_BACKWARD_1 = 0x49, - HCL_CODE_JUMP_BACKWARD_2 = 0x4A, - HCL_CODE_JUMP_BACKWARD_3 = 0x4B, + HCL_CODE_JUMP_BACKWARD_0 = 0x48, /* 72 */ + HCL_CODE_JUMP_BACKWARD_1 = 0x49, /* 73 */ + HCL_CODE_JUMP_BACKWARD_2 = 0x4A, /* 74 */ + HCL_CODE_JUMP_BACKWARD_3 = 0x4B, /* 75 */ - BCODE_JUMP_IF_TRUE_0 = 0x4C, - BCODE_JUMP_IF_TRUE_1 = 0x4D, - BCODE_JUMP_IF_TRUE_2 = 0x4E, - BCODE_JUMP_IF_TRUE_3 = 0x4F, - - 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 */ @@ -641,7 +634,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 */ + HCL_CODE_JUMP_FORWARD_IF_TRUE_X = 0xCC, /* 204 */ HCL_CODE_JUMP_FORWARD_IF_FALSE_X = 0xD0, /* 208 */ HCL_CODE_CALL_X = 0xD4, /* 212 */ @@ -661,6 +654,10 @@ enum hcl_bcode_t HCL_CODE_JUMP2_FORWARD = 0xC5, /* 197 */ HCL_CODE_JUMP2_BACKWARD = 0xC9, /* 201 */ + HCL_CODE_JUMP_FORWARD_IF_TRUE = 0xCC, /* 204 */ + HCL_CODE_JUMP2_FORWARD_IF_TRUE = 0xCD, /* 205 */ + HCL_CODE_JUMP_FORWARD_IF_FALSE = 0xD0, /* 208 */ + HCL_CODE_JUMP2_FORWARD_IF_FALSE = 0xD1, /* 209 */ BCODE_PUSH_RECEIVER = 0x81, /* 129 */ HCL_CODE_PUSH_NIL = 0x82, /* 130 */ diff --git a/lib/hcl.h b/lib/hcl.h index df4306b..1953ad6 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -839,6 +839,7 @@ struct hcl_t hcl_oop_t _quote; /* symbol */ hcl_oop_t _return; /* symbol */ hcl_oop_t _set; /* symbol */ + hcl_oop_t _until; /* symbol */ hcl_oop_t _while; /* symbol */ /* == NEVER CHANGE THE ORDER OF FIELDS BELOW == */ @@ -1025,6 +1026,7 @@ enum HCL_SYNCODE_QUOTE, HCL_SYNCODE_RETURN, HCL_SYNCODE_SET, + HCL_SYNCODE_UNTIL, HCL_SYNCODE_WHILE };