added some more code to support exception handling

stix/kernel/Context.st

@@ -1,10 +1,16 @@
 #class(#pointer) Context(Apex)
 {
+	#dcl sender ip sp ntmprs.
+
+	#method sender
+	{
+		^self.sender
+	}
 }
 
 #class(#pointer) MethodContext(Context)
 {
-	#dcl sender ip sp ntmprs method receiver home origin.
+	#dcl method receiver home origin.
 
 	#method pc
 	{
@@ -33,11 +39,16 @@
 		sp := aSP.
 		##sp := sp - 1.
 	}
+
+	#method isHandlerContext
+	{
+		^self.method primitive == 512
+	}
 }
 
 #class(#pointer) BlockContext(Context)
 {
-	#dcl caller ip sp ntmprs nargs source  home origin.
+	#dcl nargs source home origin.
 
 	#method fork
 	{
@@ -146,6 +157,12 @@
 ##		self value ifTrue: [ aBlock value. thisContext restart. ].
 	}
 
+	#method whileTrue
+	{
+		(self value) ifFalse: [^nil].
+		self whileTrue.
+	}
+
 	#method whileFalse: aBlock
 	{
 		(self value) ifTrue: [^nil].
@@ -153,6 +170,12 @@
 		self whileFalse: aBlock.
 	}
 
+	#method whileFalse
+	{
+		(self value) ifTrue: [^nil].
+		self whileFalse.
+	}
+
 	#method pc
 	{
 		^ip
@@ -179,16 +202,30 @@
 	}
 
 
-
 	"------ TODO: -------------------------------------"
 	#method on: anException do: anExceptionBlock
 	{
-		<primitive: #block_on_do>
+		| handlerActive |
-		self primitiveFailed.
+		<exception>
+		handlerActive := true.
+
+(thisContext basicAt: 9) dump.
+
+		^self value.
 	}
 
 	#method ensure: aBlock
 	{
+		"##
+		| complete returnValue |
+		<ensure>
+
+		returnValue := self valueNoContextSwitch.
+		complete ifNil: [
+			complete := true.
+			aBlock value.
+		].
+		^returnValue. ##"
 	}
 
 	#method ifCurtailed: aBlock
@@ -198,3 +235,78 @@
 	"------ TODO: -------------------------------------"
 }
 
+#class Exception(Object)
+{
+	#dcl signalContext handlerContext messageText.
+
+	#method(#class) signal
+	{
+		self new signal
+	}
+
+	#method(#class) signal: text
+	{
+		self new signal: text
+	}
+
+	#method signal 
+	{
+		self.signalContext := thisContext.
+		self isHandled
+			ifTrue: [ self handle ]
+			ifFalse: [ self notHandled ].
+	}
+
+	#method signal: text
+	{
+		self.messageText := text.
+		self signal.
+	}
+
+	#method isHandled
+	{
+		^self handlerContext notNil
+	}
+
+	#method handle
+	{
+		self return: (self.handlerContext handlerBlock value: self)
+	}
+
+	#method notHandle
+	{
+'EXCEPTION NOT HANDLED' dump.
+## TODO: debug the current process???? "
+Processor activeProcess terminate.
+	}
+
+	#method handlerContext
+	{
+		(self.handlerContext notNil) ifTrue: [ ^self.handlerContext ].
+		^self handlerContextStartingFrom: self.signalContext sender.
+	}
+
+	#method handlerContextStartingFrom: aContext
+	{
+		## Find exception handling context starting from a given context
+
+		| ctx |
+
+		ctx := aContext.
+		[ ctx notNil ]
+			whileTrue: [
+				(ctx handles: self) ifTrue: [ ^self.handlerContext := ctx ].
+				ctx := ctx sender
+			].
+		^nil
+	}
+	
+	#method return: anObject
+	{
+		Processor return: anObject to: (self.handlerContext parent)
+	}
+}
+
+#class NoSuchMessageException(Exception)
+{
+}

stix/kernel/Process.st

@@ -380,4 +380,10 @@
 	"#method signal: aSemaphore onOutput: file
 	{
 	}"
+
+	#method return: anObject to: aContext
+	{
+		<primitive: #_processor_return_to>
+		self primitiveFailed.
+	}
 }

stix/kernel/Stix.st

@@ -254,6 +254,11 @@
 #class(#pointer) CompiledMethod(Object)
 {
 	#dcl owner preamble preamble_data_1 preamble_data_2 ntmprs nargs code source.
+
+	#method preamble
+	{
+		^self.preamble
+	}
 }
 
 #include 'Context.st'.

stix/lib/comp.c

@@ -87,6 +87,7 @@ static struct voca_t
 	{  9, { 'c','l','a','s','s','i','n','s','t'                           } },
 	{  3, { 'd','c','l'                                                   } },
 	{  7, { 'd','e','c','l','a','r','e'                                   } },
+	{  9, { 'e','x','c','e','p','t','i','o','n'                           } },
 	{  6, { 'e','x','t','e','n','d'                                       } },
 	{  5, { 'f','a','l','s','e'                                           } },
 	{  8, { 'h','a','l','f','w','o','r','d'                               } },
@@ -120,6 +121,7 @@ enum voca_id_t
 	VOCA_CLASSINST,
 	VOCA_DCL,
 	VOCA_DECLARE,
+	VOCA_EXCEPTION,
 	VOCA_EXTEND,
 	VOCA_FALSE,
 	VOCA_HALFWORD,
@@ -2606,7 +2608,8 @@ static int compile_method_temporaries (stix_t* stix)
 static int compile_method_primitive (stix_t* stix)
 {
 	/* 
-	 * method-primitive := "<"  "primitive:" integer ">"
+	 * method-primitive := "<"  "primitive:" integer ">" |
+	 *                     "<"  "exception" ">"
 	 */
 	stix_ooi_t prim_no;
 	const stix_ooch_t* ptr, * end;
@@ -2618,80 +2621,84 @@ static int compile_method_primitive (stix_t* stix)
 	}
 
 	GET_TOKEN (stix);
-	if (!is_token_keyword(stix, VOCA_PRIMITIVE_COLON))
+print_oocs (&stix->c->tok.name);
+printf ("]]]]]]]]]]]]]]]]]]]]]]\n");
+	if (is_token_keyword(stix, VOCA_PRIMITIVE_COLON))
 	{
-		set_syntax_error (stix, STIX_SYNERR_PRIMITIVE, &stix->c->tok.loc, &stix->c->tok.name);
+		GET_TOKEN (stix); 
-		return -1;
+		switch (stix->c->tok.type)
-	}
+		{
+			case STIX_IOTOK_NUMLIT: /* TODO: allow only an integer */
+	/*TODO: more checks the validity of the primitive number. support number with radix and so on support more extensive syntax. support primitive name, not number*/
+				ptr = stix->c->tok.name.ptr;
+				end = ptr + stix->c->tok.name.len;
+				prim_no = 0;
+				while (ptr < end && is_digitchar(*ptr)) 
+				{
+					prim_no = prim_no * 10 + (*ptr - '0');
+					if (!STIX_OOI_IN_PREAMBLE_INDEX_RANGE(prim_no))
+					{
+						set_syntax_error (stix, STIX_SYNERR_PRIMNO, &stix->c->tok.loc, &stix->c->tok.name);
+						return -1;
+					}
 
-/* TODO: other modifiers than primitive: ? 
+					ptr++;
- * <primitive: 10>
+				}
- * <primitive: #primitive_name>
- * <some-other-modifier: xxxx>
- */
 
-	GET_TOKEN (stix); 
+				stix->c->mth.prim_no = prim_no;
-	switch (stix->c->tok.type)
+				break;
-	{
+	 
-		case STIX_IOTOK_NUMLIT: /* TODO: allow only an integer */
+			case STIX_IOTOK_SYMLIT:
-/*TODO: more checks the validity of the primitive number. support number with radix and so on support more extensive syntax. support primitive name, not number*/
+				prim_no = stix_getprimno (stix, &stix->c->tok.name);
-			ptr = stix->c->tok.name.ptr;
+				if (prim_no <= -1)
-			end = ptr + stix->c->tok.name.len;
+				{
-			prim_no = 0;
+					const stix_ooch_t* us;
-			while (ptr < end && is_digitchar(*ptr)) 
+					/* the primitive is not found */
-			{
+					us = stix_findoochar (stix->c->tok.name.ptr, stix->c->tok.name.len, '_');
-				prim_no = prim_no * 10 + (*ptr - '0');
+					if (us > stix->c->tok.name.ptr && us < stix->c->tok.name.ptr + stix->c->tok.name.len - 1)
-				if (!STIX_OOI_IN_PREAMBLE_INDEX_RANGE(prim_no))
+					{
+						stix_oow_t lit_idx;
+						/* the symbol literal contains an underscore.
+						 * and it is none of the first of the last character */
+						if (add_symbol_literal(stix, &stix->c->tok.name, &lit_idx) >= 0 &&
+						    STIX_OOI_IN_PREAMBLE_INDEX_RANGE(lit_idx))
+						{
+							stix->c->mth.prim_type = 2; /* named primitive */
+							stix->c->mth.prim_no = lit_idx;
+							break;
+						}
+					}
+
+					set_syntax_error (stix, STIX_SYNERR_PRIMNO, &stix->c->tok.loc, &stix->c->tok.name);
+					return -1;
+				}
+				else if (!STIX_OOI_IN_PREAMBLE_INDEX_RANGE(prim_no))
 				{
 					set_syntax_error (stix, STIX_SYNERR_PRIMNO, &stix->c->tok.loc, &stix->c->tok.name);
 					return -1;
 				}
 
-				ptr++;
+				stix->c->mth.prim_type = 1; 
-			}
+				stix->c->mth.prim_no = prim_no;
+				break;
 
-			stix->c->mth.prim_no = prim_no;
+			default:
-			break;
+				set_syntax_error (stix, STIX_SYNERR_INTEGER, &stix->c->tok.loc, &stix->c->tok.name);
- 
-		case STIX_IOTOK_SYMLIT:
-			prim_no = stix_getprimno (stix, &stix->c->tok.name);
-			if (prim_no <= -1)
-			{
-				const stix_ooch_t* us;
-				/* the primitive is not found */
-				us = stix_findoochar (stix->c->tok.name.ptr, stix->c->tok.name.len, '_');
-				if (us > stix->c->tok.name.ptr && us < stix->c->tok.name.ptr + stix->c->tok.name.len - 1)
-				{
-					stix_oow_t lit_idx;
-					/* the symbol literal contains an underscore.
-					 * and it is none of the first of the last character */
-					if (add_symbol_literal(stix, &stix->c->tok.name, &lit_idx) >= 0 &&
-					    STIX_OOI_IN_PREAMBLE_INDEX_RANGE(lit_idx))
-					{
-						stix->c->mth.prim_type = 2; /* named primitive */
-						stix->c->mth.prim_no = lit_idx;
-						break;
-					}
-				}
-
-				set_syntax_error (stix, STIX_SYNERR_PRIMNO, &stix->c->tok.loc, &stix->c->tok.name);
 				return -1;
-			}
+		}
-			else if (!STIX_OOI_IN_PREAMBLE_INDEX_RANGE(prim_no))
-			{
-				set_syntax_error (stix, STIX_SYNERR_PRIMNO, &stix->c->tok.loc, &stix->c->tok.name);
-				return -1;
-			}
 
-			stix->c->mth.prim_type = 1; 
-			stix->c->mth.prim_no = prim_no;
-			break;
-
-		default:
-			set_syntax_error (stix, STIX_SYNERR_INTEGER, &stix->c->tok.loc, &stix->c->tok.name);
-			return -1;
 	}
-
+	else if (is_token_word(stix, VOCA_EXCEPTION))
+	{
+/* TODO: exception handler is supposed to be used by BlockContext on:do:. 
+ *       it needs to check the number of arguments at least */
+		stix->c->mth.prim_type = 3;
+	}
+	else
+	{
+		set_syntax_error (stix, STIX_SYNERR_PRIMITIVE, &stix->c->tok.loc, &stix->c->tok.name);
+		return -1;
+	}
 
 	GET_TOKEN (stix);
 	if (!is_token_binary_selector(stix, VOCA_GT)) 
@@ -4273,12 +4280,17 @@ static int add_compiled_method (stix_t* stix)
 		preamble_code = STIX_METHOD_PREAMBLE_PRIMITIVE;
 		preamble_index = stix->c->mth.prim_no;
 	}
-	else
+	else if (stix->c->mth.prim_type == 2)
 	{
-		STIX_ASSERT (stix->c->mth.prim_type == 2);
 		preamble_code = STIX_METHOD_PREAMBLE_NAMED_PRIMITIVE;
 		preamble_index = stix->c->mth.prim_no;
 	}
+	else 
+	{
+		STIX_ASSERT (stix->c->mth.prim_type == 3);
+		preamble_code = STIX_METHOD_PREAMBLE_EXCEPTION;
+		preamble_index = 0;
+	}
 
 	STIX_ASSERT (STIX_OOI_IN_PREAMBLE_INDEX_RANGE(preamble_index));
 

stix/lib/exec.c

@@ -1608,32 +1608,43 @@ printf ("PRIMITVE VALUE RECEIVER IS NOT A BLOCK CONTEXT\n");
 static int prim_block_on_do (stix_t* stix, stix_ooi_t nargs)
 {
 	int x;
-	stix_oop_t exblk, excls;
+	stix_oop_oop_t exarr;
 	stix_oop_context_t blkctx;
+	stix_ooi_t i, j;
 
-	STIX_ASSERT (nargs == 2);
+	STIX_ASSERT (nargs >= 2);
 
-	exblk = ACTIVE_STACK_GET(stix, stix->sp);
+	if ((stix_oow_t)nargs & 1) return 0; /* it expects even number of arguments */
-	excls = ACTIVE_STACK_GET(stix, stix->sp - 1);
+
+	//for (i = 0; i < nargs; i += 2)
+	//{
+	//	exblk = ACTIVE_STACK_GET(stix, stix->sp);
+	//	excls = ACTIVE_STACK_GET(stix, stix->sp - 1);
+	//}
 
-	stix_pushtmp (stix, &exblk);
-	stix_pushtmp (stix, &excls);
 	x = __block_value (stix, nargs, 0, 0, &blkctx);
-	stix_poptmps (stix, 2);
 	if (x <= 0) return x; /* hard failure and soft failure */
 
 	/* TOOD: implement zero-cost exception handling. 
 	 *       this implementation requires allocation of a new array
 	 *       every time on:do: is executed */
-	/*
+
-	 * stix_pushtmp (stix, &blkctx);
+	stix_pushtmp (stix, (stix_oop_t*)&blkctx);
-	blkctx->exception_info = stix_instantiate (stix, stix->_array, );
+	exarr = (stix_oop_oop_t)stix_instantiate (stix, stix->_array, STIX_NULL, nargs);
 	stix_poptmp (stix);
-	 */
+	if (!exarr) return -1; /* hard failure */ /* TOOD: can't this be treated as a soft failure? */
+
+	for (i = nargs, j = 0; i > 0;)
+	{
+		--i;
+		exarr->slot[j++] = ACTIVE_STACK_GET(stix, stix->sp - i);
+		--i;
+		exarr->slot[j++] = ACTIVE_STACK_GET(stix, stix->sp - i);
+	}
 
 
 #if defined(STIX_DEBUG_EXEC_001)
-printf ("<<ENTERING BLOCK>> SP=%ld\n", (long int)stix->sp);
+printf ("<<ENTERING BLOCK BY ON:DO:>> SP=%ld\n", (long int)stix->sp);
 #endif
 	SWITCH_ACTIVE_CONTEXT (stix, (stix_oop_context_t)blkctx);
 	return 1;
@@ -1816,6 +1827,25 @@ static int prim_processor_remove_semaphore (stix_t* stix, stix_ooi_t nargs)
 	return 1;
 }
 
+static int prim_processor_return_to (stix_t* stix, stix_ooi_t nargs)
+{
+	stix_oop_t rcv, ret, ctx;
+
+	STIX_ASSERT (nargs == 2);
+
+	rcv = ACTIVE_STACK_GET(stix, stix->sp - 2);
+	ret = ACTIVE_STACK_GET(stix, stix->sp - 1);
+	ctx = ACTIVE_STACK_GET(stix, stix->sp);
+
+	if (rcv != (stix_oop_t)stix->processor) return 0;
+/* TODO: check if ctx is a block context or a method context */
+
+	ACTIVE_STACK_POPS (stix, nargs + 1); /* pop arguments and receiver */
+	SWITCH_ACTIVE_CONTEXT (stix, ctx);
+
+	return 1;
+}
+
 static int prim_integer_add (stix_t* stix, stix_ooi_t nargs)
 {
 	stix_oop_t rcv, arg, res;
@@ -2493,7 +2523,7 @@ static prim_t primitives[] =
 
 	{   0, MAX_NARGS,  prim_block_value,          "_block_value"         },
 	{   0, MAX_NARGS,  prim_block_new_process,    "_block_new_process"   },
-	{   2,  2,         prim_block_on_do,          "_block_on_do"         },
+	{   2, MAX_NARGS,  prim_block_on_do,          "_block_on_do"         },
 
 	{   0,  0,  prim_process_resume,       "_process_resume"      },
 	{   0,  0,  prim_process_terminate,    "_process_terminate"   },
@@ -2504,6 +2534,7 @@ static prim_t primitives[] =
 	{   1,  1,  prim_processor_schedule,               "_processor_schedule"            },
 	{   2,  3,  prim_processor_add_timed_semaphore,    "_processor_add_timed_semaphore" },
 	{   1,  1,  prim_processor_remove_semaphore,       "_processor_remove_semaphore" },
+	{   2,  2,  prim_processor_return_to,              "_processor_return_to" },
 
 	{   1,  1,  prim_integer_add,          "_integer_add"         },
 	{   1,  1,  prim_integer_sub,          "_integer_sub"         },
@@ -2878,7 +2909,8 @@ printf ("]\n");
 		}
 
 		default:
-			STIX_ASSERT (preamble_code == STIX_METHOD_PREAMBLE_NONE);
+			STIX_ASSERT (preamble_code == STIX_METHOD_PREAMBLE_NONE ||
+			             preamble_code == STIX_METHOD_PREAMBLE_EXCEPTION);
 			if (activate_new_method (stix, method) <= -1) return -1;
 			break;
 	}
@@ -3642,8 +3674,6 @@ printf ("<<LEAVING>> SP=%d\n", (int)stix->sp);
 					/* place the instruction pointer back at the return instruction.
 					 * even if the context is reentered, it will just return.
 					 *stix->ip--;*/
-
-
 #if defined(STIX_DEBUG_EXEC_002)
 printf ("TERMINATING A PROCESS RETURNING old_active context %p\n", stix->active_context);
 #endif
@@ -3659,8 +3689,6 @@ printf ("TERMINATED A PROCESS RETURNING %lld new active_context %p\n", (long lon
 printf ("ERROR: CAN'T RETURN FROM DEAD METHOD CONTEXT orgin->ip %ld origin->sender->ip %ld\n",
 		(long int)STIX_OOP_TO_SMOOI(stix->active_context->origin->ip), (long int)STIX_OOP_TO_SMOOI(stix->active_context->origin->sender->ip));
 printf ("ERROR: CAN'T RETURN FROM DEAD METHOD CONTEXT origin %p origin->sender %p\n", stix->active_context->origin, stix->active_context->origin->sender);
-printf ("ERROR: CAN'T RETURN FROM DEAD METHOD CONTEXT\n");
-						
 						/* TODO: proper error handling  */
 						stix->errnum = STIX_EINTERN; /* TODO: this should be caughtable at the stix level... */
 						return -1;
@@ -3714,7 +3742,6 @@ printf (">>>>>>>>>>>>>>>> METHOD RETURN FROM WITHIN A BLOCK. NON-LOCAL RETURN..
 printf ("<<<RETURNIGN TO THE INITIAL CONTEXT>>> TERMINATING SP => %ld\n", (long int)stix->sp);
 #endif
 
-
 						/* the stack contains the final return value so the stack pointer must be 0. */
 						STIX_ASSERT (stix->sp == 0); 
 
@@ -3723,14 +3750,12 @@ printf ("<<<RETURNIGN TO THE INITIAL CONTEXT>>> TERMINATING SP => %ld\n", (long
 						else
 							goto done;
 
-
 						/* TODO: store the return value to the VM register.
 						 * the caller to stix_execute() can fetch it to return it to the system */
 					}
 				}
 			#endif
 
-				
 				break;
 
 			case BCODE_RETURN_FROM_BLOCK:

stix/lib/stix-prv.h

@@ -342,7 +342,6 @@ struct stix_iotok_t
 		STIX_IOTOK_IDENT_DOTTED,
 		STIX_IOTOK_BINSEL,
 		STIX_IOTOK_KEYWORD,
-		STIX_IOTOK_PRIMITIVE,
 		STIX_IOTOK_ASSIGN,
 		STIX_IOTOK_COLON,
 		STIX_IOTOK_RETURN,

stix/lib/stix.h

@@ -464,6 +464,8 @@ struct stix_method_t
  *  6 - return -index.
  *  7 - return instvar[index] 
  *  8 - do primitive[index]
+ *  9 - do named primitive[index]
+ * 10 - exception handler
  */
 #define STIX_METHOD_MAKE_PREAMBLE(code,index)  ((((stix_ooi_t)index) << 8) | ((stix_ooi_t)code))
 #define STIX_METHOD_GET_PREAMBLE_CODE(preamble) (((stix_ooi_t)preamble) & 0xFF)
@@ -479,13 +481,14 @@ struct stix_method_t
 #define STIX_METHOD_PREAMBLE_RETURN_INSTVAR  7
 #define STIX_METHOD_PREAMBLE_PRIMITIVE       8
 #define STIX_METHOD_PREAMBLE_NAMED_PRIMITIVE 9 /* index is an index to the symbol table */
+#define STIX_METHOD_PREAMBLE_EXCEPTION       10
 
 /* the index is an 16-bit unsigned integer. */
 #define STIX_METHOD_PREAMBLE_INDEX_MIN 0x0000
 #define STIX_METHOD_PREAMBLE_INDEX_MAX 0xFFFF
 #define STIX_OOI_IN_PREAMBLE_INDEX_RANGE(num) ((num) >= STIX_METHOD_PREAMBLE_INDEX_MIN && (num) <= STIX_METHOD_PREAMBLE_INDEX_MAX)
 
-#define STIX_CONTEXT_NAMED_INSTVARS 10
+#define STIX_CONTEXT_NAMED_INSTVARS 8
 typedef struct stix_context_t stix_context_t;
 typedef struct stix_context_t* stix_oop_context_t;
 struct stix_context_t
@@ -537,10 +540,6 @@ struct stix_context_t
 	 * the source block context. */
 	stix_oop_context_t  origin; 
 
-	/* each even position (0, 2, 4, etc) contains an exception class
-	 * each odd position (1, 3, 5, etc) contains an exception handler block */
-	stix_oop_t          exception_info; 
-
 	/* variable indexed part */
 	stix_oop_t          slot[1]; /* stack */
 };