added some primitive functions

lib/comp.c

@@ -629,7 +629,7 @@ enum
 	COP_POST_WHILE_BODY,
 	COP_POST_WHILE_COND,
 
-	COP_UPDATE_BREAK,
+	COP_UPDATE_BREAK
 };
 
 /* ========================================================================= */
@@ -1365,7 +1365,6 @@ static int compile_object_list (hcl_t* hcl)
 	}
 	else
 	{
-
 		hcl_oop_t car, cdr;
 
 		if (cop != COP_COMPILE_ARGUMENT_LIST)

lib/exec.c

@@ -889,7 +889,6 @@ static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi
 	 */
 
 	/* the receiver must be a block context */
-	//HCL_ASSERT (HCL_CLASSOF(hcl, rcv_blkctx) == hcl->_block_context);
 	HCL_ASSERT (HCL_IS_CONTEXT (hcl, rcv_blkctx));
 	if (rcv_blkctx->receiver_or_source != hcl->_nil)
 	{
@@ -1042,7 +1041,7 @@ static int start_initial_process_and_context (hcl_t* hcl)
 	ctx->method_or_nargs = HCL_SMOOI_TO_OOP(0);
 /* TODO: XXXXX */
 	ctx->ntmprs = HCL_SMOOI_TO_OOP(0);
-	ctx->home = ctx; // is this correct???
+	ctx->home = ctx; /* // is this correct??? */
 /* END XXXXX */
 
 	/* [NOTE]
@@ -1867,9 +1866,10 @@ static int execute (hcl_t* hcl)
 					 * }
 					 */
 
+/*
 //					HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context) == hcl->_block_context);
 //					HCL_ASSERT (HCL_CLASSOF(hcl, hcl->processor->active->initial_context) == hcl->_block_context);
-
+*/
 					/* decrement the instruction pointer back to the return instruction.
 					 * even if the context is reentered, it will just return.
 					 *hcl->ip--;*/
@@ -1886,7 +1886,9 @@ static int execute (hcl_t* hcl)
 					if (hcl->active_context->origin == hcl->active_context)
 					{
 						/* returning from a method */
+/*
 //						HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context) == hcl->_method_context);
+*/
 						hcl->ip = -1;
 					}
 					else
@@ -1894,13 +1896,14 @@ static int execute (hcl_t* hcl)
 						hcl_oop_context_t ctx;
 
 						/* method return from within a block(including a non-local return) */
+/*
 //						HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context) == hcl->_block_context);
-
+*/
 						ctx = hcl->active_context;
 						while ((hcl_oop_t)ctx != hcl->_nil)
 						{
 						#if 0
-//							/* TODO: XXXXXXXXXXXXXX for STACK UNWINDING... */
+							/* TODO: XXXXXXXXXXXXXX for STACK UNWINDING... */
 							if (HCL_CLASSOF(hcl, ctx) == hcl->_method_context)
 							{
 								hcl_ooi_t preamble;
@@ -1921,7 +1924,9 @@ static int execute (hcl_t* hcl)
 						}
 
 						/* cannot return from a method that has returned already */
+/*
 //						HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context->origin) == hcl->_method_context);
+*/
 						HCL_ASSERT (hcl->active_context->origin->ip == HCL_SMOOI_TO_OOP(-1));
 
 						HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_ERROR, "Error - cannot return from dead context\n");
@@ -1933,11 +1938,15 @@ static int execute (hcl_t* hcl)
 						hcl->active_context->origin->ip = HCL_SMOOI_TO_OOP(-1);
 					}
 
+/*
 //					HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context->origin) == hcl->_method_context);
+*/
 					/* restore the stack pointer */
 					hcl->sp = HCL_OOP_TO_SMOOI(hcl->active_context->origin->sp);
 					SWITCH_ACTIVE_CONTEXT (hcl, hcl->active_context->origin->sender);
 
+#if 0 
+XXXXX
 					if (unwind_protect)
 					{
 						static hcl_ooch_t fbm[] = { 
@@ -1953,6 +1962,7 @@ static int execute (hcl_t* hcl)
 					}
 					else
 					{
+#endif
 						/* push the return value to the stack of the new active context */
 						HCL_STACK_PUSH (hcl, return_value);
 
@@ -1961,7 +1971,9 @@ static int execute (hcl_t* hcl)
 							/* the new active context is the fake initial context.
 							 * this context can't get executed further. */
 							HCL_ASSERT ((hcl_oop_t)hcl->active_context->sender == hcl->_nil);
+/*
 //							HCL_ASSERT (HCL_CLASSOF(hcl, hcl->active_context) == hcl->_method_context);
+*/
 							HCL_ASSERT (hcl->active_context->receiver_or_source == hcl->_nil);
 							HCL_ASSERT (hcl->active_context == hcl->processor->active->initial_context);
 							HCL_ASSERT (hcl->active_context->origin == hcl->processor->active->initial_context->origin);
@@ -1984,15 +1996,18 @@ static int execute (hcl_t* hcl)
 							 * the caller to hcl_execute() can fetch it to return it to the system */
 						}
 					}
+#if 0
 				}
+#endif
 
 				break;
 
 			case HCL_CODE_RETURN_FROM_BLOCK:
 				LOG_INST_0 (hcl, "return_from_block");
 
+/*
 //				HCL_ASSERT(HCL_CLASSOF(hcl, hcl->active_context) == hcl->_block_context);
-
+*/
 				if (hcl->active_context == hcl->processor->active->initial_context)
 				{
 					/* the active context to return from is an initial context of
@@ -2010,7 +2025,9 @@ static int execute (hcl_t* hcl)
 
 					/* the process stack is shared. the return value 
 					 * doesn't need to get moved. */
+/*
 					//XXX SWITCH_ACTIVE_CONTEXT (hcl, (hcl_oop_context_t)hcl->active_context->sender);
+*/
 					if (hcl->active_context->sender == hcl->processor->active->initial_context)
 					{
 						terminate_process (hcl, hcl->processor->active);
@@ -2099,7 +2116,6 @@ static int execute (hcl_t* hcl)
 				 * context and activates the cloned context.
 				 * this base block context is created with no 
 				 * stack for this reason. */
-				//blkctx = (hcl_oop_context_t)hcl_instantiate (hcl, hcl->_block_context, HCL_NULL, 0); 
 				blkctx = (hcl_oop_context_t)make_context (hcl, 0);
 				if (!blkctx) return -1;
 

lib/hcl.h

@@ -1055,6 +1055,7 @@ typedef struct hcl_cons_t hcl_cons_t;
 typedef struct hcl_cons_t* hcl_oop_cons_t;
 
 #define HCL_IS_NIL(hcl,v) (v == (hcl)->_nil)
+#define HCL_IS_INTEGER(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_INTEGER)
 #define HCL_IS_SYMBOL(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL)
 #define HCL_IS_SYMBOL_ARRAY(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL_ARRAY)
 #define HCL_IS_CONTEXT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONTEXT)

lib/main.c

@@ -46,6 +46,7 @@
 #	include <os2.h>
 #elif defined(__MSDOS__)
 #	include <dos.h>
+#	include <time.h>
 #elif defined(macintosh)
 #	include <Timer.h>
 #else
@@ -353,10 +354,15 @@ static int write_all (int fd, const char* ptr, hcl_oow_t len)
 
 		if (wr <= -1)
 		{
-			if (errno == EAGAIN || errno == EWOULDBLOCK)
+		#if defined(EAGAIN) && defined(EWOULDBLOCK) && (EAGAIN == EWOULDBLOCK)
-			{
+			if (errno == EAGAIN) continue;
-				continue;
+		#else
-			}
+			#	if defined(EAGAIN)
+			if (errno == EAGAIN) continue;
+			#elif defined(EWOULDBLOCK)
+			if (errno == EWOULDBLOCK) continue;
+			#endif
+		#endif
 			return -1;
 		}
 
@@ -401,8 +407,12 @@ if (mask & HCL_LOG_GC) return; /* don't show gc logs */
 	}
 	if (write_all (1, ts, tslen) <= -1) 
 	{
-		char ttt[10];
+		char ttt[20];
+#if defined(__MSDOS__) && defined(_INTELC32_)
+		sprintf (ttt, "ERR: %d\n", errno);
+#else
 		snprintf (ttt, sizeof(ttt), "ERR: %d\n", errno);
+#endif
 		write (1, ttt, strlen(ttt));
 	}
 

lib/prim.c

@@ -163,9 +163,97 @@ static int prim_log (hcl_t* hcl, hcl_ooi_t nargs)
 
 /* ------------------------------------------------------------------------- */
 
+static int oop_to_ooi (hcl_t* hcl, hcl_oop_t iv, hcl_ooi_t* ov)
+{
+	if (HCL_OOP_IS_SMOOI(iv))
+	{
+		*ov = HCL_OOP_TO_SMOOI(iv);
+		return 0;
+	}
+	else if (HCL_IS_INTEGER(hcl, iv))
+	{
+		*ov = (hcl_ooi_t)((hcl_oop_word_t)iv)->slot[0];
+		return 0;
+	}
+	else
+	{
+		/* TODO: set error number or something...to indicate primitive failure... */
+		return -1;
+	}
+}
+
+static int prim_plus (hcl_t* hcl, hcl_ooi_t nargs)
+{
+	hcl_ooi_t x = 0;
+	hcl_oow_t i;
+	hcl_oop_t arg, ret;
+
+	for (i = 0; i < nargs; i++)
+	{
+		hcl_ooi_t v;
+
+		arg = HCL_STACK_GETARG(hcl, nargs, i);
+		if (oop_to_ooi(hcl, arg, &v) <= -1) return -1;
+		x += v;
+	}
+
+	ret = hcl_makeinteger (hcl, x);
+	if (!ret) return -1;
+
+	HCL_STACK_SETRET (hcl, nargs, ret);
+	return 0;
+}
+
+static int prim_minus (hcl_t* hcl, hcl_ooi_t nargs)
+{
+	hcl_ooi_t x = 0;
+	hcl_oow_t i;
+	hcl_oop_t arg, ret;
+
+	if (nargs > 0)
+	{
+		arg = HCL_STACK_GETARG(hcl, nargs, 0);
+		if (oop_to_ooi(hcl, arg, &x) <= -1) return -1;
+		for (i = 1; i < nargs; i++)
+		{
+			hcl_ooi_t v;
+			arg = HCL_STACK_GETARG(hcl, nargs, i);
+			if (oop_to_ooi(hcl, arg, &v) <= -1) return -1;
+			x -= v;
+		}
+	}
+
+	ret = hcl_makeinteger (hcl, x);
+	if (!ret) return -1;
+
+	HCL_STACK_SETRET (hcl, nargs, ret);
+	return 0;
+}
+
+/* ------------------------------------------------------------------------- */
+
 static prim_t builtin_prims[] =
 {
-	{ 0, HCL_TYPE_MAX(hcl_oow_t), prim_log,   3,  { 'l','o','g' } }
+	{ 0, HCL_TYPE_MAX(hcl_oow_t), prim_log,   3,  { 'l','o','g' } },
+
+	/*
+	{ 2, 2,                       prim_gt,    1,  { '>' } },
+	{ 2, 2,                       prim_ge,    2,  { '>','=' } },
+	{ 2, 2,                       prim_lt,    1,  { '<' } },
+	{ 2, 2,                       prim_le,    2,  { '<','=' } },
+	{ 2, 2,                       prim_eq,    1,  { '=' } },
+	{ 2, 2,                       prim_ne,    2,  { '/','=' } },
+
+	{ 2, 2,                       prim_eql,   3,  { 'e','q','l' } },
+	{ 2, 2,                       prim_max,   3,  { 'm','a','x' } },
+	{ 2, 2,                       prim_min,   3,  { 'm','i','n' } },
+
+	{ 2, 2,                       prim_and,   3,  { 'a','n','d' } },
+	{ 2, 2,                       prim_or,    2,  { 'o','r' } },
+	{ 1, 1,                       prim_not,   3,  { 'n','o','t' } }, */
+
+	{ 0, HCL_TYPE_MAX(hcl_oow_t), prim_plus,  1,  { '+' } },
+	{ 0, HCL_TYPE_MAX(hcl_oow_t), prim_minus, 1,  { '-' } }
 };