added some code to handle while

lib/comp.c

@@ -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;

lib/decode.c

@@ -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:
+				LOG_INST_1 (hcl, "jump_if_true %zu", (hcl_oow_t)(bcode & 0x3)); /* low 2 bits */
-			case BCODE_JUMP_IF_FALSE_1:
+				break;
-			case BCODE_JUMP_IF_FALSE_2:
+
-			case BCODE_JUMP_IF_FALSE_3:
+			case HCL_CODE_JUMP_FORWARD_IF_FALSE_X:
-LOG_INST_0 (hcl, "<<<<<<<<<<<<<< JUMP NOT IMPLEMENTED YET >>>>>>>>>>>>");
+				FETCH_PARAM_CODE_TO (hcl, b1);
-hcl->errnum = HCL_ENOIMPL;
+				LOG_INST_1 (hcl, "jump_forward_if_false %zu", b1);
-return -1;
+				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);

lib/exec.c

@@ -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 HCL_CODE_JUMP_FORWARD_IF_FALSE_0:
-			case BCODE_JUMP_IF_FALSE_1:
+			case HCL_CODE_JUMP_FORWARD_IF_FALSE_1:
-			case BCODE_JUMP_IF_FALSE_2:
+			case HCL_CODE_JUMP_FORWARD_IF_FALSE_2:
-			case BCODE_JUMP_IF_FALSE_3:
+			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;

lib/gc.c

@@ -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)  }
 };
 
 /* ========================================================================= */

lib/hcl-prv.h

@@ -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 */
+	HCL_CODE_JUMP_FORWARD_IF_FALSE_0  = 0x50, /* 80 */
-	BCODE_JUMP_IF_FALSE_1          = 0x51, /* 81 */
+	HCL_CODE_JUMP_FORWARD_IF_FALSE_1  = 0x51, /* 81 */
-	BCODE_JUMP_IF_FALSE_2          = 0x52, /* 82 */
+	HCL_CODE_JUMP_FORWARD_IF_FALSE_2  = 0x52, /* 82 */
-	BCODE_JUMP_IF_FALSE_3          = 0x53, /* 83 */
+	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 */
 

lib/hcl.h

@@ -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