added some logging methods to SystemDictioanry

added Resource handling functions for use by primitive modules

stix/kernel/Collect.st

@@ -105,10 +105,51 @@
 {
 }
 
-#class SystemDictionary(Dictionary)
+#pooldic Log
 {
+	## -----------------------------------------------------------
+	## these items must follow defintions in stix.h
+	## -----------------------------------------------------------
+	#DEBUG := 1.
+	#INFO  := 2.
+	#WARN  := 4.
+	#ERROR := 8.
+	#FATAL := 16.
 }
 
+#class SystemDictionary(Dictionary)
+{
+	## the following methods may not look suitable to be placed
+	## inside a system dictionary. but they are here for quick and dirty
+	## output production from the stix code.
+	##   System logNl: 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX'.
+	##
+
+	#dcl(#pooldic) Log.
+
+	#method log: message level: level
+	{
+		<primitive: #_log>
+		## do nothing upon logging failure
+	}
+
+	#method logNl: message level: level
+	{
+		self log: message level: level.
+		self log: S'\n' level: level.
+		^self.
+	}
+
+	#method log: message
+	{
+		^self log: message level: Log.INFO.
+	}
+
+	#method logNl: message
+	{
+		^self logNl: message level: Log.INFO.
+	}
+}
 
 #class Namespace(Set)
 {

stix/kernel/Stix.st

@@ -286,6 +286,10 @@
 #include 'Except.st'.
 #include 'Process.st'.
 
+#class Resource(Object)
+{
+}
+
 #class FFI(Object)
 {
 	#dcl name handle funcs.

stix/lib/comp.c

@@ -5005,6 +5005,7 @@ static int compile_stream (stix_t* stix)
 		}
 		else if (is_token_symbol(stix, VOCA_POOLDIC))
 		{
+/* TODO: allow #pooldic within #class */
 			/* #pooldic SharedPoolDic { #abc := 20. #defg := 'ayz' } */
 			GET_TOKEN (stix);
 			if (compile_pooldic_definition(stix) <= -1) return -1;

stix/lib/exec.c

@@ -128,7 +128,7 @@
 #endif
 
 
-#define __PRIMITIVE_NAME__ (&__FUNCTION__[5])
+#define __PRIMITIVE_NAME__ (&__FUNCTION__[4])
 
 /* ------------------------------------------------------------------------- */
 static STIX_INLINE void vm_gettime (stix_t* stix, stix_ntime_t* now)
@@ -1167,6 +1167,62 @@ static int prim_dump (stix_t* stix, stix_ooi_t nargs)
 	return 1; /* success */
 }
 
+static int prim_log (stix_t* stix, stix_ooi_t nargs)
+{
+	stix_oop_t msg, level;
+
+	STIX_ASSERT (nargs >=  2);
+
+	level = STIX_STACK_GET(stix, stix->sp);
+	msg = STIX_STACK_GET(stix, stix->sp - 1);
+
+/* TODO: SUPPORT ARBITRARY NUMBERS OF MESSAGES */
+	if (!STIX_OOP_IS_SMOOI(level)) level = STIX_SMOOI_TO_OOP(STIX_LOG_INFO);
+
+	if (STIX_OOP_IS_POINTER(msg) && STIX_OBJ_GET_FLAGS_TYPE(msg))
+	{
+		stix_ooi_t n;
+		stix_oow_t rem;
+		const stix_ooch_t* ptr;
+
+		rem = STIX_OBJ_GET_SIZE(msg);
+		ptr = ((stix_oop_char_t)msg)->slot;
+
+	start_over:
+		while (rem > 0)
+		{
+			if (*ptr == '\0') 
+			{
+				n = stix_logbfmt (stix, STIX_LOG_APP | STIX_OOP_TO_SMOOI(level), "%C", *ptr);
+				STIX_ASSERT (n == 1);
+				rem -= n;
+				ptr += n;
+				goto start_over;
+			}
+
+			n = stix_logbfmt (stix, STIX_LOG_APP | STIX_OOP_TO_SMOOI(level), "%.*S", rem, ptr);
+			if (n <= -1) break;
+			if (n == 0) 
+			{
+				/* to skip the unprinted character. 
+				 * actually, this check is not needed because of '\0' skipping
+				 * at the beginning  of the loop */
+				n = stix_logbfmt (stix, STIX_LOG_APP | STIX_OOP_TO_SMOOI(level), "%C", *ptr);
+				STIX_ASSERT (n == 1);
+			}
+			rem -= n;
+			ptr += n;
+		}
+	}
+	else
+	{
+		stix_logbfmt (stix, STIX_LOG_APP | STIX_OOP_TO_SMOOI(level), "%O", msg);
+	}
+
+	STIX_STACK_POPS (stix, nargs); /* delete arguments, keep self */
+	return 1;
+}
+
 static int prim_identical (stix_t* stix, stix_ooi_t nargs)
 {
 	stix_oop_t rcv, arg, b;
@@ -1514,7 +1570,7 @@ static int prim_context_goto (stix_t* stix, stix_ooi_t nargs)
 	if (STIX_CLASSOF(stix, rcv) != stix->_method_context)
 	{
 		STIX_LOG2 (stix, STIX_LOG_PRIMITIVE | STIX_LOG_ERROR, 
-			"Error(%hs) - invalid receiver, not a method context- %O\n", __PRIMITIVE_NAME__, rcv);
+			"Error(%hs) - invalid receiver, not a method context - %O\n", __PRIMITIVE_NAME__, rcv);
 		return 0;
 	}
 
@@ -1560,7 +1616,7 @@ static int __block_value (stix_t* stix, stix_ooi_t rcv_blkctx_offset, stix_ooi_t
 	{
 		/* the receiver must be a block context */
 		STIX_LOG2 (stix, STIX_LOG_PRIMITIVE | STIX_LOG_ERROR, 
-			"Error(%hs) - invalid receiver, not a block context- %O\n", __PRIMITIVE_NAME__, rcv_blkctx);
+			"Error(%hs) - invalid receiver, not a block context - %O\n", __PRIMITIVE_NAME__, rcv_blkctx);
 		return 0;
 	}
 
@@ -1745,6 +1801,8 @@ static int prim_process_terminate (stix_t* stix, stix_ooi_t nargs)
 	stix_oop_t rcv;
 	STIX_ASSERT (nargs == 0);
 
+/* TODO: need to run ensure blocks here..
+ * when it's executed here. it does't have to be in Exception>>handleException when there is no exception handler */
 	rcv = STIX_STACK_GET(stix, stix->sp);
 	if (STIX_CLASSOF(stix,rcv) != stix->_process) return 0;
 
@@ -2598,6 +2656,7 @@ typedef struct prim_t prim_t;
 static prim_t primitives[] =
 {
 	{   0, MAX_NARGS,  prim_dump,                      "_dump"                },
+	{   2,  2,  prim_log,                              "_log"                 },
 
 	{   1,  1,  prim_identical,                        "_identical"           },
 	{   1,  1,  prim_not_identical,                    "_not_identical"       },

stix/lib/ignite.c

@@ -149,6 +149,7 @@ static int ignite_1 (stix_t* stix)
 	stix->_small_integer     = alloc_kernel_class (stix, 0, STIX_CLASS_SPEC_MAKE(0, 0, STIX_OBJ_TYPE_OOP));
 	stix->_large_positive_integer = alloc_kernel_class (stix, 0, STIX_CLASS_SPEC_MAKE(0, 1, STIX_OBJ_TYPE_LIWORD));
 	stix->_large_negative_integer = alloc_kernel_class (stix, 0, STIX_CLASS_SPEC_MAKE(0, 1, STIX_OBJ_TYPE_LIWORD));
+	stix->_resource          = alloc_kernel_class (stix, 0, STIX_CLASS_SPEC_MAKE(0, 0, STIX_OBJ_TYPE_OOP));
 
 	if (!stix->_apex              || !stix->_undefined_object  || 
 	    !stix->_object            || !stix->_string            ||
@@ -164,7 +165,7 @@ static int ignite_1 (stix_t* stix)
 
 	    !stix->_true_class        || !stix->_false_class       || 
 	    !stix->_character         || !stix->_small_integer     || 
-	    !stix->_large_positive_integer  || !stix->_large_negative_integer) return -1;
+	    !stix->_large_positive_integer  || !stix->_large_negative_integer || !stix->_resource) return -1;
 
 	STIX_OBJ_SET_CLASS (stix->_nil, stix->_undefined_object);
 	return 0;

stix/lib/logfmt.c

@@ -299,6 +299,10 @@ static void print_object (stix_t* stix, unsigned int mask, stix_oop_t oop)
 	{
 		stix_logbfmt (stix, mask, "$%.1C", STIX_OOP_TO_CHAR(oop));
 	}
+	else if (STIX_OOP_IS_RSRC(oop))
+	{
+		stix_logbfmt (stix, mask, "%zX", stix->rsrc.ptr[STIX_OOP_TO_RSRC(oop)]);
+	}
 	else
 	{
 		stix_oop_class_t c;
@@ -327,11 +331,81 @@ static void print_object (stix_t* stix, unsigned int mask, stix_oop_t oop)
 		}
 		else if (STIX_OBJ_GET_FLAGS_TYPE(oop) == STIX_OBJ_TYPE_CHAR)
 		{
-			if ((stix_oop_t)c == stix->_symbol) stix_logbfmt (stix, mask, "#");
+			if ((stix_oop_t)c == stix->_symbol) 
-			else if ((stix_oop_t)c == stix->_string) stix_logbfmt (stix, mask, "'");
+			{
+				stix_logbfmt (stix, mask, "#%.*S", STIX_OBJ_GET_SIZE(oop), ((stix_oop_char_t)oop)->slot);
+			}
+			else /*if ((stix_oop_t)c == stix->_string)*/
+			{
+				stix_ooch_t ch;
+				int escape = 0;
 
-			stix_logbfmt (stix, mask, "%.*S", STIX_OBJ_GET_SIZE(oop), ((stix_oop_char_t)oop)->slot);
+				for (i = 0; i < STIX_OBJ_GET_SIZE(oop); i++)
-			if ((stix_oop_t)c == stix->_string) stix_logbfmt (stix,  mask, "'");
+				{
+					ch = ((stix_oop_char_t)oop)->slot[i];
+					if (ch < ' ') 
+					{
+						escape = 1;
+						break;
+					}
+				}
+
+				if (escape)
+				{
+					stix_ooch_t escaped;
+
+					stix_logbfmt (stix, mask, "S'");
+					for (i = 0; i < STIX_OBJ_GET_SIZE(oop); i++)
+					{
+						ch = ((stix_oop_char_t)oop)->slot[i];
+						if (ch < ' ') 
+						{
+							switch (ch)
+							{
+								case '\0':
+									escaped = '0';
+									break;
+								case '\r':
+									escaped = 'r';
+									break;
+								case '\t':
+									escaped = 't';
+									break;
+								case '\f':
+									escaped = 'f';
+									break;
+								case '\b':
+									escaped = 'b';
+									break;
+								case '\v':
+									escaped = 'v';
+									break;
+								case '\a':
+									escaped = 'a';
+									break;
+								default:
+									escaped = ch;
+									break;
+							}
+
+							if (escaped == ch)
+								stix_logbfmt (stix, mask, "\\x%X", ch);
+							else
+								stix_logbfmt (stix, mask, "\\%C", escaped);
+						}
+						else
+						{
+							stix_logbfmt (stix, mask, "%C", ch);
+						}
+					}
+					
+					stix_logbfmt (stix, mask, "'");
+				}
+				else
+				{
+					stix_logbfmt (stix, mask, "'%.*S'", STIX_OBJ_GET_SIZE(oop), ((stix_oop_char_t)oop)->slot);
+				}
+			}
 		}
 		else if (STIX_OBJ_GET_FLAGS_TYPE(oop) == STIX_OBJ_TYPE_BYTE)
 		{

stix/lib/stix.c

@@ -94,8 +94,9 @@ int stix_init (stix_t* stix, stix_mmgr_t* mmgr, stix_oow_t heapsz, const stix_vm
 	stix->option.dfl_sysdic_size = STIX_DFL_SYSDIC_SIZE;
 	stix->option.dfl_procstk_size = STIX_DFL_PROCSTK_SIZE;
 
+/* TODO: intoduct a permanent heap */
 	/*stix->permheap = stix_makeheap (stix, what is the best size???);
-	if (!stix->curheap) goto oops; */
+	if (!stix->permheap) goto oops; */
 	stix->curheap = stix_makeheap (stix, heapsz);
 	if (!stix->curheap) goto oops;
 	stix->newheap = stix_makeheap (stix, heapsz);
@@ -105,6 +106,11 @@ int stix_init (stix_t* stix, stix_mmgr_t* mmgr, stix_oow_t heapsz, const stix_vm
 	stix_rbt_setstyle (&stix->pmtable, stix_getrbtstyle(STIX_RBT_STYLE_INLINE_COPIERS));
 
 	fill_bigint_tables (stix);
+
+	stix->tagged_classes[STIX_OOP_TAG_SMINT] = &stix->_small_integer;
+	stix->tagged_classes[STIX_OOP_TAG_CHAR] = &stix->_character;
+	stix->tagged_classes[STIX_OOP_TAG_RSRC] = &stix->_resource;
+
 	return 0;
 
 oops:
@@ -152,10 +158,19 @@ void stix_fini (stix_t* stix)
 	stix_rbt_walk (&stix->pmtable, unload_primitive_module, stix);
 	stix_rbt_fini (&stix->pmtable);
 
+/* TOOD: persistency? storing objects to image file? */
 	stix_killheap (stix, stix->newheap);
 	stix_killheap (stix, stix->curheap);
 	stix_killheap (stix, stix->permheap);
 
+	if (stix->rsrc.ptr)
+	{
+		stix_freemem (stix, stix->rsrc.ptr);
+		stix->rsrc.free = 0;
+		stix->rsrc.capa = 0;
+		stix->rsrc.ptr = STIX_NULL;
+	}
+
 	/* deregister all callbacks */
 	while (stix->cblist) stix_deregcb (stix, stix->cblist);
 
@@ -332,3 +347,61 @@ void stix_freemem (stix_t* stix, void* ptr)
 {
 	STIX_MMGR_FREE (stix->mmgr, ptr);
 }
+
+
+
+stix_oop_t stix_makersrc (stix_t* stix, stix_oow_t v)
+{
+	stix_oop_t imm;
+	stix_oow_t avail;
+
+	if (stix->rsrc.free >= stix->rsrc.capa)
+	{
+		stix_oow_t* tmp;
+		stix_ooi_t newcapa, i;
+
+		newcapa = stix->rsrc.capa + 256;
+
+		tmp = stix_reallocmem (stix, stix->rsrc.ptr, STIX_SIZEOF(*tmp) * newcapa);
+		if (!tmp) return STIX_NULL;
+
+		for (i = stix->rsrc.capa; i < newcapa; i++) tmp[i] = i + 1;
+		stix->rsrc.free = i;
+		stix->rsrc.ptr = tmp;
+		stix->rsrc.capa = newcapa;
+	}
+
+	avail = stix->rsrc.free;
+	stix->rsrc.free = stix->rsrc.ptr[stix->rsrc.free];
+	stix->rsrc.ptr[avail] = v;
+
+	/* there must not be too many immedates in the whole system. */
+	STIX_ASSERT (STIX_IN_SMOOI_RANGE(avail));
+	return STIX_RSRC_TO_OOP(avail);
+
+	return imm;
+}
+
+void stix_killrsrc (stix_t* stix, stix_oop_t imm)
+{
+	if (STIX_OOP_IS_RSRC(stix))
+	{
+		stix_ooi_t v;
+
+		v = STIX_OOP_TO_RSRC(stix);
+
+		/* the value of v, if properly created by stix_makeimm(), must
+		 * fall in the following range. when storing and loading the values
+		 * from an image file, you must take extra care not to break this
+		 * assertion */
+		STIX_ASSERT (v >= 0 && v < stix->rsrc.capa);
+		stix->rsrc.ptr[v] = stix->rsrc.free;
+		stix->rsrc.free = v;
+	}
+}
+
+stix_oow_t stix_getrsrcval (stix_t* stix, stix_oop_t imm)
+{
+	STIX_ASSERT (STIX_OOP_IS_RSRC(imm));
+	return stix->rsrc.ptr[STIX_OOP_TO_RSRC(imm)];
+}

stix/lib/stix.h

@@ -172,19 +172,26 @@ typedef struct stix_obj_word_t*     stix_oop_word_t;
 #define STIX_OOP_TAG_BITS   2
 #define STIX_OOP_TAG_SMINT  1
 #define STIX_OOP_TAG_CHAR   2
+#define STIX_OOP_TAG_RSRC   3
 
-#define STIX_OOP_IS_NUMERIC(oop) (((stix_oow_t)oop) & (STIX_OOP_TAG_SMINT | STIX_OOP_TAG_CHAR))
-#define STIX_OOP_IS_POINTER(oop) (!STIX_OOP_IS_NUMERIC(oop))
 #define STIX_OOP_GET_TAG(oop) (((stix_oow_t)oop) & STIX_LBMASK(stix_oow_t, STIX_OOP_TAG_BITS))
+#define STIX_OOP_IS_NUMERIC(oop) (STIX_OOP_GET_TAG(oop) != 0)
+#define STIX_OOP_IS_POINTER(oop) (STIX_OOP_GET_TAG(oop) == 0)
+
+#define STIX_OOP_IS_SMOOI(oop) (STIX_OOP_GET_TAG(oop) == STIX_OOP_TAG_SMINT)
+#define STIX_OOP_IS_CHAR(oop) (STIX_OOP_GET_TAG(oop) == STIX_OOP_TAG_CHAR)
+#define STIX_OOP_IS_RSRC(oop) (STIX_OOP_GET_TAG(oop) == STIX_OOP_TAG_RSRC)
 
-#define STIX_OOP_IS_SMOOI(oop) (((stix_ooi_t)oop) & STIX_OOP_TAG_SMINT)
-#define STIX_OOP_IS_CHAR(oop) (((stix_oow_t)oop) & STIX_OOP_TAG_CHAR)
 #define STIX_SMOOI_TO_OOP(num) ((stix_oop_t)((((stix_ooi_t)(num)) << STIX_OOP_TAG_BITS) | STIX_OOP_TAG_SMINT))
 #define STIX_OOP_TO_SMOOI(oop) (((stix_ooi_t)oop) >> STIX_OOP_TAG_BITS)
 #define STIX_CHAR_TO_OOP(num) ((stix_oop_t)((((stix_oow_t)(num)) << STIX_OOP_TAG_BITS) | STIX_OOP_TAG_CHAR))
 #define STIX_OOP_TO_CHAR(oop) (((stix_oow_t)oop) >> STIX_OOP_TAG_BITS)
 
-/* SMOOI takes up 62 bit on a 64-bit architecture and 30 bits 
+/* RSRC(resurce) is a index to the VM's resource table(stix->rsrc.ptr) */
+#define STIX_RSRC_TO_OOP(num) ((stix_oop_t)((((stix_oow_t)(num)) << STIX_OOP_TAG_BITS) | STIX_OOP_TAG_RSRC))
+#define STIX_OOP_TO_RSRC(oop) (((stix_oow_t)oop) >> STIX_OOP_TAG_BITS)
+
+/* SMOOI takes up 62 bits on a 64-bit architecture and 30 bits 
  * on a 32-bit architecture. The absolute value takes up 61 bits and 29 bits
  * respectively for the 1 sign bit. */
 #define STIX_SMOOI_BITS (STIX_OOI_BITS - STIX_OOP_TAG_BITS)
@@ -628,10 +635,14 @@ struct stix_process_scheduler_t
  * The STIX_CLASSOF() macro return the class of an object including a numeric
  * object encoded into a pointer.
  */
+/*
 #define STIX_CLASSOF(stix,oop) ( \
 	STIX_OOP_IS_SMOOI(oop)? (stix)->_small_integer: \
 	STIX_OOP_IS_CHAR(oop)? (stix)->_character: STIX_OBJ_GET_CLASS(oop) \
 )
+* */
+#define STIX_CLASSOF(stix,oop) \
+	(STIX_OOP_GET_TAG(oop)? *stix->tagged_classes[STIX_OOP_GET_TAG(oop)]: STIX_OBJ_GET_CLASS(oop))
 
 /**
  * The STIX_BYTESOF() macro returns the size of the payload of
@@ -816,8 +827,11 @@ struct stix_t
 	stix_oop_t _small_integer; /* SmallInteger */
 	stix_oop_t _large_positive_integer; /* LargePositiveInteger */
 	stix_oop_t _large_negative_integer; /* LargeNegativeInteger */
+
+	stix_oop_t _resource;
 	/* == NEVER CHANGE THE ORDER OF FIELDS ABOVE == */
 
+	stix_oop_t* tagged_classes[4];
 	stix_oop_set_t symtab; /* system-wide symbol table. instance of SymbolSet */
 	stix_oop_set_t sysdic; /* system dictionary. instance of SystemDictionary */
 	stix_oop_process_scheduler_t processor; /* instance of ProcessScheduler */
@@ -856,6 +870,15 @@ struct stix_t
 	} bigint[37];
 	/* == END BIGINT CONVERSION == */
 
+	/* == RSRC MANAGEMENT == */
+	struct
+	{
+		stix_oow_t* ptr;
+		stix_oow_t  free;
+		stix_oow_t  capa;
+	} rsrc;
+	/* == END RSRC MANAGEMENT == */
+
 #if defined(STIX_INCLUDE_COMPILER)
 	stix_compiler_t* c;
 #endif
@@ -894,7 +917,8 @@ enum stix_log_mask_t
 	STIX_LOG_MNEMONIC  = (1 << 8), /* bytecode mnemonic */
 	STIX_LOG_GC        = (1 << 9),
 	STIX_LOG_IC        = (1 << 10), /* instruction cycle, fetch-decode-execute */
-	STIX_LOG_PRIMITIVE = (1 << 11)
+	STIX_LOG_PRIMITIVE = (1 << 11),
+	STIX_LOG_APP       = (1 << 12) /* stix applications, set by stix logging primitive */
 };
 typedef enum stix_log_mask_t stix_log_mask_t;