started the if handling

hcl/lib/comp.c

@@ -447,6 +447,33 @@ static int emit_push_literal (hcl_t* hcl, hcl_oop_t obj)
 	return 0;
 }
 
+static HCL_INLINE void patch_long_jump (hcl_t* hcl, hcl_ooi_t jip, hcl_ooi_t jump_offset)
+{
+	if (jump_offset > MAX_CODE_JUMP)
+	{
+		/* switch to JUMP2 instruction to allow a bigger jump offset.
+		 * up to twice MAX_CODE_JUMP only */
+		
+		HCL_ASSERT (jump_offset <= MAX_CODE_JUMP * 2);
+
+		HCL_ASSERT (hcl->code.bc.arr->slot[jip] == HCL_CODE_JUMP_FORWARD_X ||
+		            hcl->code.bc.arr->slot[jip] == HCL_CODE_JUMP_BACKWARD_X ||
+		            hcl->code.bc.arr->slot[jip] == HCL_CODE_JUMP_FORWARD_IF_TRUE ||
+		            hcl->code.bc.arr->slot[jip] == HCL_CODE_JUMP_FORWARD_IF_FALSE);
+
+		/* JUMP2 instructions are chosen to be greater than its JUMP counterpart by 1 */
+		patch_instruction (hcl, jip, hcl->code.bc.arr->slot[jip] + 1); 
+		jump_offset -= MAX_CODE_JUMP;
+	}
+
+#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
+}
+
 /* ========================================================================= */
 static HCL_INLINE int _insert_cframe (hcl_t* hcl, hcl_ooi_t index, int opcode, hcl_oop_t operand)
 {
@@ -573,6 +600,9 @@ enum
 	COP_EMIT_RETURN,
 	COP_EMIT_SET,
 
+	COP_POST_IF_COND,
+	COP_POST_IF_BODY,
+
 	COP_POST_UNTIL_BODY,
 	COP_POST_UNTIL_COND,
 	COP_POST_WHILE_BODY,
@@ -588,7 +618,7 @@ static int compile_break (hcl_t* hcl, hcl_oop_t src)
 	hcl_oop_t obj;
 	hcl_ooi_t i;
 
-	HCL_ASSERT (HCL_BRANDOF(hcl,src) == HCL_BRAND_CONS);
+	HCL_ASSERT (HCL_IS_CONS(hcl, src));
 	HCL_ASSERT (HCL_CONS_CAR(src) == hcl->_break);
 
 	obj = HCL_CONS_CDR(src);
@@ -644,8 +674,55 @@ static int compile_break (hcl_t* hcl, hcl_oop_t src)
 
 static int compile_if (hcl_t* hcl, hcl_oop_t src)
 {
-/* TODO: NOT IMPLEMENTED */
+	hcl_oop_t obj, cond;
-	return -1;
+	hcl_ooi_t cond_pos;
+	hcl_cframe_t* cf;
+
+	HCL_ASSERT (HCL_IS_CONS(hcl, src));
+	HCL_ASSERT (HCL_CONS_CAR(src) == hcl->_if);
+
+	/* (if (< 20 30) 
+	 * 	(do this)
+	 *   (do that)
+	 * elif (< 20 30)
+	 *   (do it)
+	 * else
+	 *   (do this finally)
+	 * )
+	 */
+	obj = HCL_CONS_CDR(src);
+
+	if (HCL_IS_NIL(hcl, obj))
+	{
+		/* no value */
+		HCL_DEBUG1 (hcl, "Syntax error - no condition specified in if - %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 if - %O\n", src);
+		hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */
+		return -1;
+	}
+
+	cond_pos = hcl->code.bc.len; /* position where the bytecode for the conditional is emitted */
+	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_IF_COND, obj); /* 2 */
+	cf = GET_SUBCFRAME (hcl);
+	cf->u.post_if.cond_pos = cond_pos;
+	cf->u.post_if.body_pos = 0; /* unknown yet */
+/* TODO: pass information on the conditional if it's an absoluate true or absolute false to
+ *       eliminate some code .. i can't eliminate code because there can be else or elsif... 
+ *       if absoluate true, don't need else or other elsif part
+ *       if absoluate false, else or other elsif part is needed.
+ */
+	return 0;
 }
 
 static int compile_lambda (hcl_t* hcl, hcl_oop_t src)
@@ -655,7 +732,7 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src)
 	hcl_ooi_t jump_inst_pos;
 	hcl_oow_t saved_tv_count, tv_dup_start;
 
-	HCL_ASSERT (HCL_BRANDOF(hcl,src) == HCL_BRAND_CONS);
+	HCL_ASSERT (HCL_IS_CONS(hcl, src));
 	HCL_ASSERT (HCL_CONS_CAR(src) == hcl->_lambda);
 
 	saved_tv_count = hcl->c->tv.size;
@@ -711,9 +788,6 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src)
 				return -1;
 			}
 
-	/* TODO: check duplicates within only the argument list. duplicates against outer-scope are ok.
-	 * is this check necessary? */
-
 			if (add_temporary_variable (hcl, arg, tv_dup_start) <= -1) 
 			{
 				if (hcl->errnum == HCL_EEXIST)
@@ -830,16 +904,15 @@ 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_IS_CONS(hcl, src));
-
-	HCL_ASSERT (HCL_BRANDOF(hcl,src) == HCL_BRAND_CONS);
 	HCL_ASSERT (HCL_CONS_CAR(src) == hcl->_return);
 
+	obj = HCL_CONS_CDR(src);
+
 	if (HCL_IS_NIL(hcl, obj))
 	{
 /* TODO: should i allow (return)? does it return the last value on the stack? */
@@ -877,11 +950,11 @@ static int compile_set (hcl_t* hcl, hcl_oop_t src)
 	hcl_oop_t obj, var, val;
 	hcl_oow_t index;
 
-	obj = HCL_CONS_CDR(src);
+	HCL_ASSERT (HCL_IS_CONS(hcl, src));
-
-	HCL_ASSERT (HCL_BRANDOF(hcl,src) == HCL_BRAND_CONS);
 	HCL_ASSERT (HCL_CONS_CAR(src) == hcl->_set);
 
+	obj = HCL_CONS_CDR(src);
+
 	if (HCL_IS_NIL(hcl, obj))
 	{
 		HCL_DEBUG1 (hcl, "Syntax error - no variable name in set - %O\n", src);
@@ -963,12 +1036,12 @@ static int compile_while (hcl_t* hcl, hcl_oop_t src, int next_cop)
 	hcl_oow_t cond_pos;
 	hcl_cframe_t* cf;
 
-	obj = HCL_CONS_CDR(src);
+	HCL_ASSERT (HCL_IS_CONS(hcl, src));
-
-	HCL_ASSERT (HCL_BRANDOF(hcl,src) == HCL_BRAND_CONS);
 	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);
 
+	obj = HCL_CONS_CDR(src);
+
 	if (HCL_IS_NIL(hcl, obj))
 	{
 		/* no value */
@@ -1005,10 +1078,10 @@ static int compile_cons_expression (hcl_t* hcl, hcl_oop_t obj)
 	hcl_oop_t car;
 	int syncode;
 
-	HCL_ASSERT (HCL_BRANDOF(hcl,obj) == HCL_BRAND_CONS);
+	HCL_ASSERT (HCL_IS_CONS(hcl, obj));
 
 	car = HCL_CONS_CAR(obj);
-	if (HCL_BRANDOF(hcl,car) == HCL_BRAND_SYMBOL && (syncode = HCL_OBJ_GET_FLAGS_SYNCODE(car)))
+	if (HCL_IS_SYMBOL(hcl,car) && (syncode = HCL_OBJ_GET_FLAGS_SYNCODE(car)))
 	{
 		switch (syncode)
 		{
@@ -1300,6 +1373,75 @@ static int compile_object_list (hcl_t* hcl)
 	return 0;
 }
 
+/* ========================================================================= */
+static HCL_INLINE int post_if_cond (hcl_t* hcl)
+{
+	hcl_cframe_t* cf;
+	hcl_ooi_t jump_inst_pos;
+	hcl_ooi_t cond_pos, body_pos;
+
+	cf = GET_TOP_CFRAME(hcl);
+	HCL_ASSERT (cf->opcode == COP_POST_IF_COND);
+
+	cond_pos = cf->u.post_while.cond_pos;
+	HCL_ASSERT (hcl->code.bc.len < HCL_SMOOI_MAX);
+	jump_inst_pos = hcl->code.bc.len;
+
+	if (emit_single_param_instruction (hcl, HCL_CODE_JUMP_FORWARD_IF_FALSE, MAX_CODE_JUMP) <= -1) return -1;
+	/* to drop the result of the conditional when it is true */
+	if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP) <= -1) return -1; 
+
+	HCL_ASSERT (hcl->code.bc.len < HCL_SMOOI_MAX);
+	body_pos = hcl->code.bc.len;
+
+	SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_LIST, cf->operand); /* 1 */
+	PUSH_SUBCFRAME (hcl, COP_POST_IF_BODY, HCL_SMOOI_TO_OOP(jump_inst_pos)); /* 2 */
+	cf = GET_SUBCFRAME(hcl);
+	cf->u.post_if.cond_pos = cond_pos;
+	cf->u.post_if.body_pos = body_pos;
+	return 0;
+}
+
+static HCL_INLINE int post_if_body (hcl_t* hcl)
+{
+	hcl_cframe_t* cf;
+	hcl_ooi_t jip;
+	hcl_oow_t jump_offset;
+
+	cf = GET_TOP_CFRAME(hcl);
+	HCL_ASSERT (cf->opcode == COP_POST_IF_BODY);
+	HCL_ASSERT (HCL_OOP_IS_SMOOI(cf->operand));
+
+	jip = HCL_OOP_TO_SMOOI(cf->operand);
+
+	if (hcl->code.bc.len <= cf->u.post_while.body_pos)
+	{
+		/* if body is empty */
+		/*if (emit_byte_instruction (hcl, HCL_CODE_PUSH_NIL) <= -1) return -1;*/
+
+		/* if body is empty, remove all instructions generated for the body so far */
+		hcl->code.bc.len = jip;
+		goto done;
+	}
+
+	HCL_ASSERT (hcl->code.bc.len >= cf->u.post_while.cond_pos);
+	/* HCL_CODE_LONG_PARAM_SIZE + 1 => size of the long JUMP_FORWARD_IF_FALSE instruction */
+	jump_offset = hcl->code.bc.len - jip - (HCL_BCODE_LONG_PARAM_SIZE + 1);
+
+	if (jump_offset > MAX_CODE_JUMP * 2)
+	{
+		HCL_DEBUG1 (hcl, "code in if body too big - size %zu\n", jump_offset);
+		hcl_setsynerr (hcl, HCL_SYNERR_BLKFLOOD, HCL_NULL, HCL_NULL); /* error location */
+		return -1;
+	}
+	patch_long_jump (hcl, jip, jump_offset);
+
+/* TOOD: if 'else' or 'elsif' appears, process further... */
+done:
+	POP_CFRAME (hcl);
+	return 0;
+}
+
 /* ========================================================================= */
 static HCL_INLINE int post_while_cond (hcl_t* hcl)
 {
@@ -1344,7 +1486,7 @@ static HCL_INLINE int post_while_body (hcl_t* hcl)
 {
 	hcl_cframe_t* cf;
 	hcl_ooi_t jip;
-	hcl_oow_t jump_offset, code_size;
+	hcl_ooi_t jump_offset;
 
 	cf = GET_TOP_CFRAME(hcl);
 	HCL_ASSERT (cf->opcode == COP_POST_UNTIL_BODY || cf->opcode == COP_POST_WHILE_BODY);
@@ -1365,32 +1507,21 @@ static HCL_INLINE int post_while_body (hcl_t* hcl)
 		if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP) <= -1) return -1;
 	}
 
+	HCL_ASSERT (hcl->code.bc.len < HCL_SMOOI_MAX);
 	jump_offset = hcl->code.bc.len - cf->u.post_while.cond_pos + 1;
 	if (jump_offset > 3) jump_offset += HCL_BCODE_LONG_PARAM_SIZE;
 	if (emit_single_param_instruction (hcl, HCL_CODE_JUMP_BACKWARD_0, jump_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/JUMP_FORWARD_IF_TRUE instruction */
-	code_size = hcl->code.bc.len - jip - (HCL_BCODE_LONG_PARAM_SIZE + 1);
+	jump_offset = hcl->code.bc.len - jip - (HCL_BCODE_LONG_PARAM_SIZE + 1);
-
+	if (jump_offset > MAX_CODE_JUMP * 2)
-	if (code_size > MAX_CODE_JUMP)
 	{
-		/* switch to JUMP2 instruction to allow a bigger jump offset.
+		HCL_DEBUG1 (hcl, "code in loop body too big - size %zu\n", jump_offset);
-		 * up to twice MAX_CODE_JUMP only */
+		hcl_setsynerr (hcl, HCL_SYNERR_BLKFLOOD, HCL_NULL, HCL_NULL); /* error location */
-		patch_instruction (hcl, jip, ((cf->opcode == COP_POST_UNTIL_BODY)? HCL_CODE_JUMP2_FORWARD_IF_TRUE: HCL_CODE_JUMP2_FORWARD_IF_FALSE)); 
+		return -1;
-		jump_offset = code_size - MAX_CODE_JUMP;
 	}
-	else
+	patch_long_jump (hcl, jip, jump_offset);
-	{
-		jump_offset = code_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;
@@ -1412,20 +1543,11 @@ static int update_break (hcl_t* hcl)
 	/* HCL_CODE_LONG_PARAM_SIZE + 1 => size of the long JUMP_FORWARD instruction */
 	jump_offset = hcl->code.bc.len - jip - (HCL_BCODE_LONG_PARAM_SIZE + 1);
 
-	if (jump_offset > MAX_CODE_JUMP)
+	/* no explicit about jump_offset. because break can only place inside
-	{
+	 * a loop, the same check in post_while_body() must assert
-		/* switch to JUMP2 instruction to allow a bigger jump offset.
+	 * this break jump_offset to be small enough */
-		 * up to twice MAX_CODE_JUMP only */
+	HCL_ASSERT (jump_offset <= MAX_CODE_JUMP * 2);
-		patch_instruction (hcl, jip, HCL_CODE_JUMP2_FORWARD); 
+	patch_long_jump (hcl, jip, jump_offset);
-		jump_offset -= MAX_CODE_JUMP;
-	}
-
-#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;
@@ -1483,29 +1605,7 @@ static HCL_INLINE int emit_lambda (hcl_t* hcl)
 		hcl_setsynerr (hcl, HCL_SYNERR_BLKFLOOD, HCL_NULL, HCL_NULL); /* error location */
 		return -1;
 	}
-	else 
+	patch_long_jump (hcl, jip, block_code_size);
-	{
-		hcl_oow_t jump_offset;
-
-		if (block_code_size > MAX_CODE_JUMP)
-		{
-			/* switch to JUMP2 instruction to allow a bigger jump offset.
-			 * up to twice MAX_CODE_JUMP only */
-			patch_instruction (hcl, jip, HCL_CODE_JUMP2_FORWARD);
-			jump_offset = block_code_size - MAX_CODE_JUMP;
-		}
-		else
-		{
-			jump_offset = block_code_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;
@@ -1639,6 +1739,14 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
 				if (emit_set (hcl) <= -1) goto oops;
 				break;
 
+			case COP_POST_IF_COND:
+				if (post_if_cond (hcl) <= -1) goto oops;
+				break;
+
+			case COP_POST_IF_BODY:
+				if (post_if_body (hcl) <= -1) goto oops;
+				break;
+
 			case COP_POST_UNTIL_BODY:
 			case COP_POST_WHILE_BODY:
 				if (post_while_body (hcl) <= -1) goto oops;

hcl/lib/exec.c

@@ -1506,13 +1506,15 @@ static int execute (hcl_t* hcl)
 			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;
+				/*if (HCL_STACK_GETTOP(hcl) == hcl->_true) hcl->ip += b1; TODO: _true or not _false?*/
+				if (HCL_STACK_GETTOP(hcl) != hcl->_false) hcl->ip += b1;
 				break;
 
 			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;
+				/*if (HCL_STACK_GETTOP(hcl) == hcl->_true) hcl->ip += MAX_CODE_JUMP + b1;*/
+				if (HCL_STACK_GETTOP(hcl) != hcl->_false) hcl->ip += MAX_CODE_JUMP + b1;
 				break;
 
 			case HCL_CODE_JUMP_FORWARD_IF_FALSE:

hcl/lib/hcl-prv.h

@@ -294,6 +294,12 @@ struct hcl_cframe_t
 			hcl_ooi_t cond_pos;
 			hcl_ooi_t body_pos;
 		} post_while;
+
+		struct
+		{
+			hcl_ooi_t cond_pos;
+			hcl_ooi_t body_pos;
+		} post_if;
 	} u;
 };
 
@@ -436,7 +442,9 @@ SHORT INSTRUCTION CODE                                        LONG INSTRUCTION C
 
 
 68-71    0100 01XX JUMP_FORWARD                               196  1100 0100 XXXXXXXX JUMP_FORWARD_X
+                                                              197  1100 0101 XXXXXXXX JUMP2_FORWARD
 72-75    0100 10XX JUMP_BACKWARD                              200  1100 1000 XXXXXXXX JUMP_BACKWARD_X
+                                                              201  1100 1001 XXXXXXXX JUMP2_BACKWARD
 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
@@ -634,8 +642,6 @@ enum hcl_bcode_t
 
 	HCL_CODE_JUMP_FORWARD_X           = 0xC4, /* 196 */
 	HCL_CODE_JUMP_BACKWARD_X          = 0xC8, /* 200 */
-	HCL_CODE_JUMP_FORWARD_IF_TRUE_X   = 0xCC, /* 204 */
-	HCL_CODE_JUMP_FORWARD_IF_FALSE_X  = 0xD0, /* 208 */
 
 	HCL_CODE_CALL_X                   = 0xD4, /* 212 */
 

hcl/lib/hcl.h

@@ -94,6 +94,8 @@ enum hcl_synerrnum_t
 	HCL_SYNERR_DOTBANNED,     /* . disallowed */
 	HCL_SYNERR_INCLUDE,       /* #include error */
 
+	HCL_SYNERR_LOOPFLOOD,     /* loop body too big */
+	HCL_SYNERR_IFFLOOD,       /* if body too big */
 	HCL_SYNERR_BLKFLOOD,      /* lambda block too big */
 	HCL_SYNERR_BLKDEPTH,      /* lambda block too deep */
 	HCL_SYNERR_ARGNAMELIST,   /* argument name list expected */

hcl/lib/main.c

@@ -585,6 +585,8 @@ static char* syntax_error_msg[] =
 	". disallowed",
 	"#include error",
 
+	"loop body too big",
+	"if body too big",
 	"lambda block too big",
 	"lambda block too deep",
 	"argument name list expected",