in the course of adding break

lib/comp.c

@@ -448,19 +448,15 @@ static int emit_push_literal (hcl_t* hcl, hcl_oop_t obj)
 }
 
 /* ========================================================================= */
-
+static HCL_INLINE int _insert_cframe (hcl_t* hcl, hcl_ooi_t index, int opcode, hcl_oop_t operand)
-static int push_cframe (hcl_t* hcl, int opcode, hcl_oop_t operand)
 {
 	hcl_cframe_t* tmp;
 
-	if (hcl->c->cfs.top == HCL_TYPE_MAX(hcl_ooi_t))
+	HCL_ASSERT (index >= 0);
-	{
-		hcl->errnum = HCL_ETOOBIG;
-		return -1;
-	}
 	
 	hcl->c->cfs.top++;
 	HCL_ASSERT (hcl->c->cfs.top >= 0);
+	HCL_ASSERT (index <= hcl->c->cfs.top);
 
 	if ((hcl_oow_t)hcl->c->cfs.top >= hcl->c->cfs.capa)
 	{
@@ -478,13 +474,40 @@ static int push_cframe (hcl_t* hcl, int opcode, hcl_oop_t operand)
 		hcl->c->cfs.ptr = tmp;
 	}
 
-	tmp = &hcl->c->cfs.ptr[hcl->c->cfs.top];
+	if (index < hcl->c->cfs.top)
+	{
+		HCL_MEMMOVE (&hcl->c->cfs.ptr[index + 1], &hcl->c->cfs.ptr[index], (hcl->c->cfs.top - index) * HCL_SIZEOF(*tmp));
+	}
+
+	tmp = &hcl->c->cfs.ptr[index];
 	tmp->opcode = opcode;
 	tmp->operand = operand;
 	/* leave tmp->u untouched/uninitialized */
 	return 0;
 }
 
+static int insert_cframe (hcl_t* hcl, hcl_ooi_t index, int opcode, hcl_oop_t operand)
+{
+	if (hcl->c->cfs.top == HCL_TYPE_MAX(hcl_ooi_t))
+	{
+		hcl->errnum = HCL_ETOOBIG;
+		return -1;
+	}
+
+	return _insert_cframe (hcl, index, opcode, operand);
+}
+
+static int push_cframe (hcl_t* hcl, int opcode, hcl_oop_t operand)
+{
+	if (hcl->c->cfs.top == HCL_TYPE_MAX(hcl_ooi_t))
+	{
+		hcl->errnum = HCL_ETOOBIG;
+		return -1;
+	}
+
+	return _insert_cframe (hcl, hcl->c->cfs.top + 1, opcode, operand);
+}
+
 static HCL_INLINE void pop_cframe (hcl_t* hcl)
 {
 	HCL_ASSERT (hcl->c->cfs.top >= 0);
@@ -494,6 +517,9 @@ static HCL_INLINE void pop_cframe (hcl_t* hcl)
 #define PUSH_CFRAME(hcl,opcode,operand) \
 	do { if (push_cframe(hcl,opcode,operand) <= -1) return -1; } while(0)
 
+#define INSERT_CFRAME(hcl,index,opcode,operand) \
+	do { if (insert_cframe(hcl,index,opcode,operand) <= -1) return -1; } while(0)
+
 #define POP_CFRAME(hcl) pop_cframe(hcl)
 
 #define POP_ALL_CFRAMES(hcl) (hcl->c->cfs.top = -1)
@@ -550,11 +576,61 @@ enum
 	COP_POST_UNTIL_BODY,
 	COP_POST_UNTIL_COND,
 	COP_POST_WHILE_BODY,
-	COP_POST_WHILE_COND
+	COP_POST_WHILE_COND,
+
+	COP_UPDATE_BREAK,
 };
 
 /* ========================================================================= */
 
+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_CONS_CAR(src) == hcl->_break);
+
+	obj = HCL_CONS_CDR(src);
+	if (!HCL_IS_NIL(hcl,obj))
+	{
+		if (HCL_IS_CONS(hcl,obj))
+		{
+			HCL_DEBUG1 (hcl, "Syntax error - redundant argument in break - %O\n", src);
+			hcl_setsynerr (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL); /* TODO: error location */
+		}
+		else
+		{
+			HCL_DEBUG1 (hcl, "Syntax error - redundant cdr in break - %O\n", src);
+			hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */
+			return -1;
+		}
+		return -1;
+	}
+
+	for (i = hcl->c->cfs.top; i >= 0; --i)
+	{
+		const hcl_cframe_t* tcf;
+		tcf = &hcl->c->cfs.ptr[i];
+		if (tcf->opcode == COP_POST_UNTIL_BODY || tcf->opcode == COP_POST_WHILE_BODY)
+		{
+			hcl_oow_t jump_inst_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_0, MAX_CODE_JUMP) <= -1) return -1;
+			INSERT_CFRAME (hcl, i, COP_UPDATE_BREAK, HCL_SMOOI_TO_OOP(jump_inst_pos));
+
+			POP_CFRAME (hcl);
+			return 0;
+		}
+	}
+
+	HCL_DEBUG1 (hcl, "Syntax error - break outside loop - %O\n", src);
+	hcl_setsynerr (hcl, HCL_SYNERR_BREAK, HCL_NULL, HCL_NULL); /* TODO: error location */
+	return -1;
+}
+
 static int compile_if (hcl_t* hcl, hcl_oop_t src)
 {
 /* TODO: NOT IMPLEMENTED */
@@ -580,7 +656,7 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src)
 		hcl_setsynerr (hcl, HCL_SYNERR_ARGNAMELIST, HCL_NULL, HCL_NULL); /* TODO: error location */
 		return -1;
 	}
-	else if (HCL_BRANDOF(hcl, obj) != HCL_BRAND_CONS)
+	else if (!HCL_IS_CONS(hcl, obj))
 	{
 		HCL_DEBUG1 (hcl, "Syntax error - redundant cdr in lambda - %O\n", src);
 		hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */
@@ -597,7 +673,7 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src)
 	{
 		hcl_oop_t arg, ptr;
 
-		if (HCL_BRANDOF(hcl, args) != HCL_BRAND_CONS)
+		if (!HCL_IS_CONS(hcl, args))
 		{
 			HCL_DEBUG1 (hcl, "Syntax error - not a lambda argument list - %O\n", args);
 			hcl_setsynerr (hcl, HCL_SYNERR_ARGNAMELIST, HCL_NULL, HCL_NULL); /* TODO: error location */
@@ -610,7 +686,7 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src)
 		do
 		{
 			arg = HCL_CONS_CAR(ptr);
-			if (HCL_BRANDOF(hcl, arg) != HCL_BRAND_SYMBOL)
+			if (!HCL_IS_SYMBOL(hcl, arg))
 			{
 				HCL_DEBUG1 (hcl, "Syntax error - lambda argument not a symbol - %O\n", arg);
 				hcl_setsynerr (hcl, HCL_SYNERR_ARGNAME, HCL_NULL, HCL_NULL); /* TODO: error location */
@@ -631,7 +707,7 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src)
 			nargs++;
 
 			ptr = HCL_CONS_CDR(ptr);
-			if (HCL_BRANDOF(hcl, ptr) != HCL_BRAND_CONS) 
+			if (!HCL_IS_CONS(hcl, ptr)) 
 			{
 				if (!HCL_IS_NIL(hcl, ptr))
 				{
@@ -905,7 +981,17 @@ static int compile_cons_expression (hcl_t* hcl, hcl_oop_t obj)
 		switch (syncode)
 		{
 			case HCL_SYNCODE_BEGIN:
+HCL_DEBUG0 (hcl, "BEGIN NOT IMPLEMENTED...\n");
+/* TODO: not implemented yet */
+				break;
+
+			case HCL_SYNCODE_BREAK:
+				/* break */
+				if (compile_break (hcl, obj) <= -1) return -1;
+				break;
+
 			case HCL_SYNCODE_DEFUN:
+HCL_DEBUG0 (hcl, "DEFUN NOT IMPLEMENTED...\n");
 /* TODO: not implemented yet */
 				break;
 
@@ -949,7 +1035,7 @@ static int compile_cons_expression (hcl_t* hcl, hcl_oop_t obj)
 		/* normal function call 
 		 *  (<operator> <operand1> ...) */
 		hcl_ooi_t nargs;
-		hcl_oow_t oldtop;
+		hcl_ooi_t oldtop;
 		hcl_cframe_t* cf;
 		hcl_oop_t cdr;
 
@@ -1136,7 +1222,7 @@ static int compile_object_list (hcl_t* hcl)
 		hcl_oop_t car, cdr;
 		int cop;
 
-		if (HCL_BRANDOF(hcl, cf->operand) != HCL_BRAND_CONS)
+		if (!HCL_IS_CONS(hcl, cf->operand))
 		{
 			HCL_DEBUG1 (hcl, "Syntax error - redundant cdr in the object list - %O\n", cf->operand);
 			hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */
@@ -1150,7 +1236,9 @@ static int compile_object_list (hcl_t* hcl)
 
 		if (!HCL_IS_NIL(hcl, cdr))
 		{
-			/* (+ 1 2 3) - argument list. 1, 2, 3 pushed must remain in 
+			/* there is a next statement to compile 
+			 *
+			 * (+ 1 2 3) - argument list. 1, 2, 3 pushed must remain in 
 			 *             the stack until the function '+' is called.
 			 *
 			 * (lambda (x y) (+ x 10) (+ y 20)) 
@@ -1161,6 +1249,22 @@ static int compile_object_list (hcl_t* hcl)
 			if (cop == COP_COMPILE_OBJECT_LIST)
 			{
 				/* let's arrange to emit POP before generating code for the rest of the list */
+
+				hcl_oop_t tmp;
+
+				/* look ahead for some special functions */
+				tmp = HCL_CONS_CAR(cdr);
+				if (!HCL_IS_CONS(hcl, tmp))
+				{
+					/* this check is duplicate of the check at the beginning
+					 * of this function. if not for look-ahead, this block
+					 * could be removed */
+					HCL_DEBUG1 (hcl, "Syntax error - redundant cdr in the object list - %O\n", cf->operand);
+					hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */
+					return -1;
+				}
+
+				if (HCL_CONS_CAR(tmp) != hcl->_break) /* TODO: other special forms??? */
 					PUSH_SUBCFRAME (hcl, COP_EMIT_POP, hcl->_nil);
 			}
 		}
@@ -1255,6 +1359,14 @@ patch_instruction (hcl, jip + 2, jump_offset & 0xFF);
 
 /* ========================================================================= */
 
+static int update_break (hcl_t* hcl)
+{
+	HCL_DEBUG0 (hcl, "TOOD: update break...\n");
+	return -1;
+}
+
+/* ========================================================================= */
+
 static HCL_INLINE int emit_call (hcl_t* hcl)
 {
 	hcl_cframe_t* cf;
@@ -1348,7 +1460,6 @@ static HCL_INLINE int emit_pop (hcl_t* hcl)
 	return n;
 }
 
-
 static HCL_INLINE int emit_return (hcl_t* hcl)
 {
 	hcl_cframe_t* cf;
@@ -1471,6 +1582,10 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
 				if (post_while_cond (hcl) <= -1) goto oops;
 				break;
 
+			case COP_UPDATE_BREAK:
+				if (update_break (hcl) <= -1) goto oops;
+				break;
+
 			default:
 				HCL_DEBUG1 (hcl, "Internal error - invalid compiler opcode %d\n", cf->opcode);
 				hcl->errnum = HCL_EINTERN;

lib/gc.c

@@ -35,6 +35,7 @@ static struct
 } syminfo[] =
 {
 	{  5, { 'b','e','g','i','n' },         HCL_SYNCODE_BEGIN,   HCL_OFFSETOF(hcl_t,_begin)  },
+	{  5, { 'b','r','e','a','k' },         HCL_SYNCODE_BREAK,   HCL_OFFSETOF(hcl_t,_break)  },
 	{  5, { 'd','e','f','u','n' },         HCL_SYNCODE_DEFUN,   HCL_OFFSETOF(hcl_t,_defun)  },
 	{  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) },

lib/hcl.h

@@ -104,7 +104,9 @@ enum hcl_synerrnum_t
 	HCL_SYNERR_ARGFLOOD,      /* too many arguments defined */
 	HCL_SYNERR_VARFLOOD,      /* too many variables defined */
 	HCL_SYNERR_VARDCLBANNED,  /* variable declaration disallowed */
-	HCL_SYNERR_VARNAMEDUP     /* duplicate variable name */
+	HCL_SYNERR_VARNAMEDUP,    /* duplicate variable name */
+
+	HCL_SYNERR_BREAK          /* break outside loop */
 };
 typedef enum hcl_synerrnum_t hcl_synerrnum_t;
 
@@ -833,6 +835,7 @@ struct hcl_t
 	hcl_oop_t _false;
 
 	hcl_oop_t _begin; /* symbol */
+	hcl_oop_t _break; /* symbol */
 	hcl_oop_t _defun; /* symbol */
 	hcl_oop_t _if;     /* symbol */
 	hcl_oop_t _lambda; /* symbol */
@@ -1020,6 +1023,7 @@ enum
 {
 	/* SYNCODE 0 means it's not a syncode object. so it begins with 1 */
 	HCL_SYNCODE_BEGIN = 1,
+	HCL_SYNCODE_BREAK,
 	HCL_SYNCODE_DEFUN,
 	HCL_SYNCODE_IF,
 	HCL_SYNCODE_LAMBDA,

lib/main.c

@@ -595,7 +595,9 @@ static char* syntax_error_msg[] =
 	"too many arguments defined",
 	"too many variables defined",
 	"variable declaration disallowed",
-	"duplicate variable name"
+	"duplicate variable name",
+
+	"break outside loop"
 };
 
 static void print_synerr (hcl_t* hcl)