added some code to handle primitives and the call instruction

hcl/configure

@@ -16910,7 +16910,8 @@ done
 
 
 
-for ac_func in gettimeofday settimeofday clock_gettime clock_settime
+
+for ac_func in gettimeofday settimeofday clock_gettime clock_settime getitimer setitimer
 do :
   as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh`
 ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var"

hcl/configure.ac

@@ -130,7 +130,8 @@ dnl	[],
 dnl	[#include <stddef.h>])
 
 dnl check functions
-AC_CHECK_FUNCS([gettimeofday settimeofday clock_gettime clock_settime])
+
+AC_CHECK_FUNCS([gettimeofday settimeofday clock_gettime clock_settime getitimer setitimer])
 AC_CHECK_FUNCS([backtrace backtrace_symbols])
 AC_CHECK_FUNCS([makecontext swapcontext getcontext setcontext])
 AC_CHECK_FUNCS([snprintf _vsnprintf _vsnwprintf])

hcl/lib/Makefile.am

@@ -40,6 +40,7 @@ libhcl_la_SOURCES = \
 	heap.c \
 	logfmt.c \
 	obj.c \
+	prim.c \
 	print.c \
 	rbt.c \
 	read.c \

hcl/lib/Makefile.in

@@ -132,8 +132,9 @@ am_libhcl_la_OBJECTS = libhcl_la-bigint.lo libhcl_la-comp.lo \
 	libhcl_la-debug.lo libhcl_la-decode.lo libhcl_la-dic.lo \
 	libhcl_la-exec.lo libhcl_la-gc.lo libhcl_la-hcl.lo \
 	libhcl_la-heap.lo libhcl_la-logfmt.lo libhcl_la-obj.lo \
-	libhcl_la-print.lo libhcl_la-rbt.lo libhcl_la-read.lo \
+	libhcl_la-prim.lo libhcl_la-print.lo libhcl_la-rbt.lo \
-	libhcl_la-sym.lo libhcl_la-utf8.lo libhcl_la-utl.lo
+	libhcl_la-read.lo libhcl_la-sym.lo libhcl_la-utf8.lo \
+	libhcl_la-utl.lo
 libhcl_la_OBJECTS = $(am_libhcl_la_OBJECTS)
 AM_V_lt = $(am__v_lt_@AM_V@)
 am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@)
@@ -392,6 +393,7 @@ libhcl_la_SOURCES = \
 	heap.c \
 	logfmt.c \
 	obj.c \
+	prim.c \
 	print.c \
 	rbt.c \
 	read.c \
@@ -566,6 +568,7 @@ distclean-compile:
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-heap.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-logfmt.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-obj.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-prim.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-print.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-rbt.Plo@am__quote@
 @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-read.Plo@am__quote@
@@ -674,6 +677,13 @@ libhcl_la-obj.lo: obj.c
 @AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
 @am__fastdepCC_FALSE@	$(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libhcl_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libhcl_la-obj.lo `test -f 'obj.c' || echo '$(srcdir)/'`obj.c
 
+libhcl_la-prim.lo: prim.c
+@am__fastdepCC_TRUE@	$(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libhcl_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libhcl_la-prim.lo -MD -MP -MF $(DEPDIR)/libhcl_la-prim.Tpo -c -o libhcl_la-prim.lo `test -f 'prim.c' || echo '$(srcdir)/'`prim.c
+@am__fastdepCC_TRUE@	$(AM_V_at)$(am__mv) $(DEPDIR)/libhcl_la-prim.Tpo $(DEPDIR)/libhcl_la-prim.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	$(AM_V_CC)source='prim.c' object='libhcl_la-prim.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@	$(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libhcl_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libhcl_la-prim.lo `test -f 'prim.c' || echo '$(srcdir)/'`prim.c
+
 libhcl_la-print.lo: print.c
 @am__fastdepCC_TRUE@	$(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libhcl_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libhcl_la-print.lo -MD -MP -MF $(DEPDIR)/libhcl_la-print.Tpo -c -o libhcl_la-print.lo `test -f 'print.c' || echo '$(srcdir)/'`print.c
 @am__fastdepCC_TRUE@	$(AM_V_at)$(am__mv) $(DEPDIR)/libhcl_la-print.Tpo $(DEPDIR)/libhcl_la-print.Plo

hcl/lib/comp.c

@@ -65,10 +65,10 @@ static int add_literal (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t* index)
 		hcl_oow_t newcapa;
 
 		newcapa = capa + 20000; /* TODO: set a better resizing policy */
-		tmp = hcl_remakengcarray (hcl, hcl->code.lit.arr, newcapa);
+		tmp = hcl_remakengcarray (hcl, (hcl_oop_t)hcl->code.lit.arr, newcapa);
 		if (!tmp) return -1;
 
-		hcl->code.lit.arr = tmp;
+		hcl->code.lit.arr = (hcl_oop_oop_t)tmp;
 	}
 
 	*index = hcl->code.lit.len;
@@ -536,7 +536,6 @@ static int push_subcframe (hcl_t* hcl, int opcode, hcl_oop_t operand)
 
 enum 
 {
-	COP_EXIT,
 	COP_COMPILE_OBJECT,
 	COP_COMPILE_OBJECT_LIST,
 	COP_COMPILE_ARGUMENT_LIST,
@@ -1209,9 +1208,6 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
 
 		switch (cf->opcode)
 		{
-			case COP_EXIT:
-				goto done;
-
 			case COP_COMPILE_OBJECT:
 				if (compile_object (hcl) <= -1) goto oops;
 				break;
@@ -1243,7 +1239,10 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
 		}
 	}
 
-done:
+	/* emit the pop instruction to clear the final result */
+/* TODO: for interactive use, this value must be accessible by the executor... how to do it? */
+	if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP) <= -1) goto oops;
+
 	HCL_ASSERT (GET_TOP_CFRAME_INDEX(hcl) < 0);
 	HCL_ASSERT (hcl->c->tv.size == 0);
 	HCL_ASSERT (hcl->c->blk.depth == 0);

hcl/lib/decode.c

@@ -29,10 +29,10 @@
 
 #define DECODE_LOG_MASK (HCL_LOG_MNEMONIC)
 
-#define LOG_INST_0(hcl,fmt) HCL_LOG0(hcl, DECODE_LOG_MASK, "\t" fmt "\n")
+#define LOG_INST_0(hcl,fmt) HCL_LOG1(hcl, DECODE_LOG_MASK, "%010zd " fmt "\n", fetched_instruction_pointer)
-#define LOG_INST_1(hcl,fmt,a1) HCL_LOG1(hcl, DECODE_LOG_MASK, "\t" fmt "\n",a1)
+#define LOG_INST_1(hcl,fmt,a1) HCL_LOG2(hcl, DECODE_LOG_MASK, "%010zd " fmt "\n", fetched_instruction_pointer, a1)
-#define LOG_INST_2(hcl,fmt,a1,a2) HCL_LOG2(hcl, DECODE_LOG_MASK, "\t" fmt "\n", a1, a2)
+#define LOG_INST_2(hcl,fmt,a1,a2) HCL_LOG3(hcl, DECODE_LOG_MASK, "%010zd " fmt "\n", fetched_instruction_pointer, a1, a2)
-#define LOG_INST_3(hcl,fmt,a1,a2,a3) HCL_LOG3(hcl, DECODE_LOG_MASK, "\t" fmt "\n", a1, a2, a3)
+#define LOG_INST_3(hcl,fmt,a1,a2,a3) HCL_LOG4(hcl, DECODE_LOG_MASK, "%010zd " fmt "\n", fetched_instruction_pointer, a1, a2, a3)
 
 #define FETCH_BYTE_CODE(hcl) (cdptr[ip++])
 #define FETCH_BYTE_CODE_TO(hcl,v_ooi) (v_ooi = FETCH_BYTE_CODE(hcl))
@@ -50,7 +50,7 @@
 int hcl_decode (hcl_t* hcl, hcl_ooi_t start, hcl_ooi_t end)
 {
 	hcl_oob_t bcode, * cdptr;
-	hcl_ooi_t ip = start;
+	hcl_ooi_t ip = start, fetched_instruction_pointer;
 	hcl_oow_t b1, b2;
 
 	/* the instruction at the offset 'end' is not decoded.
@@ -66,6 +66,7 @@ int hcl_decode (hcl_t* hcl, hcl_ooi_t start, hcl_ooi_t end)
 /* TODO: check if ip increases beyond bcode when fetching parameters too */
 	while (ip < end)
 	{
+		fetched_instruction_pointer = ip;
 		FETCH_BYTE_CODE_TO(hcl, bcode);
 
 		switch (bcode)
@@ -529,7 +530,7 @@ return -1;
 	/* print literal frame contents */
 	for (ip = 0; ip < hcl->code.lit.len; ip++)
 	{
-		LOG_INST_2 (hcl, " @%-3zd %O", ip, ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[ip]);
+		HCL_LOG2(hcl, DECODE_LOG_MASK, "@%-9zd %O\n", ip, ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[ip]);
 	}
 
 	return 0;

hcl/lib/exec.c

@@ -110,10 +110,10 @@
 #if defined(HCL_DEBUG_VM_EXEC)
 #	define LOG_MASK_INST (HCL_LOG_IC | HCL_LOG_MNEMONIC)
 
-#	define LOG_INST_0(hcl,fmt) HCL_LOG0(hcl, LOG_MASK_INST, "\t" fmt "\n")
+#	define LOG_INST_0(hcl,fmt) HCL_LOG1(hcl, LOG_MASK_INST, "%010zd " fmt "\n", fetched_instruction_pointer)
-#	define LOG_INST_1(hcl,fmt,a1) HCL_LOG1(hcl, LOG_MASK_INST, "\t" fmt "\n",a1)
+#	define LOG_INST_1(hcl,fmt,a1) HCL_LOG2(hcl, LOG_MASK_INST, "%010zd " fmt "\n",fetched_instruction_pointer, a1)
-#	define LOG_INST_2(hcl,fmt,a1,a2) HCL_LOG2(hcl, LOG_MASK_INST, "\t" fmt "\n", a1, a2)
+#	define LOG_INST_2(hcl,fmt,a1,a2) HCL_LOG3(hcl, LOG_MASK_INST, "%010zd " fmt "\n", fetched_instruction_pointer, a1, a2)
-#	define LOG_INST_3(hcl,fmt,a1,a2,a3) HCL_LOG3(hcl, LOG_MASK_INST, "\t" fmt "\n", a1, a2, a3)
+#	define LOG_INST_3(hcl,fmt,a1,a2,a3) HCL_LOG4(hcl, LOG_MASK_INST, "%010zd " fmt "\n", fetched_instruction_pointer, a1, a2, a3)
 
 #else
 #	define LOG_INST_0(hcl,fmt)
@@ -267,7 +267,6 @@ static void vm_cleanup (hcl_t* hcl)
 
 /* ------------------------------------------------------------------------- */
 
-
 static HCL_INLINE hcl_oop_t make_context (hcl_t* hcl, hcl_ooi_t ntmprs)
 {
 	HCL_ASSERT (ntmprs >= 0);
@@ -867,6 +866,7 @@ static void update_sem_heap (hcl_t* hcl, hcl_ooi_t index, hcl_oop_semaphore_t ne
 	else
 		sift_down_sem_heap (hcl, index);
 }
+/* ------------------------------------------------------------------------- */
 
 static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi_t nargs, hcl_oop_context_t* pblkctx)
 {
@@ -898,18 +898,20 @@ static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi
 		 * you can't send 'value' again to reactivate it.
 		 * For example, [thisContext value] value. */
 		HCL_ASSERT (HCL_OBJ_GET_SIZE(rcv_blkctx) > HCL_CONTEXT_NAMED_INSTVARS);
-		HCL_LOG1 (hcl, HCL_LOG_PRIMITIVE | HCL_LOG_ERROR, 
+		HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_ERROR, 
 			"Error - re-valuing of a block context - %O\n", rcv_blkctx);
-		return 0;
+		hcl->errnum = HCL_ERECALL;
+		return -1;
 	}
 	HCL_ASSERT (HCL_OBJ_GET_SIZE(rcv_blkctx) == HCL_CONTEXT_NAMED_INSTVARS);
 
 	if (HCL_OOP_TO_SMOOI(rcv_blkctx->method_or_nargs) != nargs)
 	{
-		HCL_LOG3 (hcl, HCL_LOG_PRIMITIVE | HCL_LOG_ERROR, 
+		HCL_LOG3 (hcl, HCL_LOG_IC | HCL_LOG_ERROR, 
 			"Error - wrong number of arguments to a block context %O - expecting %zd, got %zd\n",
 			rcv_blkctx, HCL_OOP_TO_SMOOI(rcv_blkctx->method_or_nargs), nargs);
-		return 0;
+		hcl->errnum = HCL_ECALLARG;
+		return -1;
 	}
 
 	/* the number of temporaries stored in the block context
@@ -917,7 +919,6 @@ static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi
 	 * simple calculation is needed to find the number of local temporaries */
 	local_ntmprs = HCL_OOP_TO_SMOOI(rcv_blkctx->ntmprs) -
 	               HCL_OOP_TO_SMOOI(((hcl_oop_context_t)rcv_blkctx->home)->ntmprs);
-printf ("%d %d\n", (int)local_ntmprs, (int)nargs);
 	HCL_ASSERT (local_ntmprs >= nargs);
 
 
@@ -956,34 +957,46 @@ printf ("%d %d\n", (int)local_ntmprs, (int)nargs);
 	blkctx->sender = hcl->active_context;
 
 	*pblkctx = blkctx;
-	return 1;
-}
-
-static int activate_context (hcl_t* hcl, hcl_ooi_t nargs)
-{
-	int x;
-	hcl_oop_context_t rcv_blkctx, blkctx;
-
-	rcv_blkctx = (hcl_oop_context_t)HCL_STACK_GETRCV(hcl, nargs);
-	HCL_ASSERT (HCL_IS_CONTEXT (hcl, rcv_blkctx));
-#if 0
-	if (HCL_CLASSOF(hcl, rcv_blkctx) != hcl->_block_context)
-	{
-		/* the receiver must be a block context */
-		HCL_LOG1 (hcl, HCL_LOG_PRIMITIVE | HCL_LOG_ERROR, 
-			"Error - invalid receiver, not a block context - %O\n", rcv_blkctx);
 	return 0;
 }
-#endif
 
-	x = __activate_context (hcl, rcv_blkctx, nargs, &blkctx);
+static HCL_INLINE int activate_context (hcl_t* hcl, hcl_ooi_t nargs)
-	if (x <= 0) return x; /* hard failure and soft failure */
+{
+	int x;
+	hcl_oop_context_t rcv, blkctx;
+
+	rcv = (hcl_oop_context_t)HCL_STACK_GETRCV(hcl, nargs);
+	HCL_ASSERT (HCL_IS_CONTEXT (hcl, rcv));
+
+	x = __activate_context (hcl, rcv, nargs, &blkctx);
+	if (x <= -1) return -1;
 
 	SWITCH_ACTIVE_CONTEXT (hcl, (hcl_oop_context_t)blkctx);
-	return 1;
+	return 0;
 }
 
+/* ------------------------------------------------------------------------- */
+static HCL_INLINE int call_primitive (hcl_t* hcl, hcl_ooi_t nargs)
+{
+	hcl_oop_word_t rcv;
 
+	rcv = (hcl_oop_word_t)HCL_STACK_GETRCV(hcl, nargs);
+	HCL_ASSERT (HCL_IS_PRIM (hcl, rcv));
+
+	if (nargs < rcv->slot[1] && nargs > rcv->slot[2])
+	{
+/* TODO: include a primitive name... */
+		HCL_LOG3 (hcl, HCL_LOG_IC | HCL_LOG_ERROR, 
+			"Error - wrong number of arguments to a primitive - expecting %zd-%zd, got %zd\n",
+			rcv->slot[1], rcv->slot[2], nargs);
+		hcl->errnum = HCL_ECALLARG;
+		return -1;
+	}
+
+	return ((hcl_prim_impl_t)rcv->slot[0]) (hcl, nargs);
+}
+
+/* ------------------------------------------------------------------------- */
 static hcl_oop_process_t start_initial_process (hcl_t* hcl, hcl_oop_context_t ctx)
 {
 	hcl_oop_process_t proc;
@@ -1007,97 +1020,6 @@ static hcl_oop_process_t start_initial_process (hcl_t* hcl, hcl_oop_context_t ct
 	return proc;
 }
 
-static HCL_INLINE int activate_new_method (hcl_t* hcl, hcl_oop_method_t mth)
-{
-	hcl_oop_context_t ctx;
-	hcl_ooi_t i;
-	hcl_ooi_t ntmprs, nargs;
-
-	ntmprs = HCL_OOP_TO_SMOOI(mth->tmpr_count);
-	nargs = HCL_OOP_TO_SMOOI(mth->tmpr_nargs);
-
-	HCL_ASSERT (ntmprs >= 0);
-	HCL_ASSERT (nargs <= ntmprs);
-
-	hcl_pushtmp (hcl, (hcl_oop_t*)&mth);
-	ctx = (hcl_oop_context_t)make_context (hcl, ntmprs);
-	hcl_poptmp (hcl);
-	if (!ctx) return -1;
-
-	ctx->sender = hcl->active_context; 
-	ctx->ip = HCL_SMOOI_TO_OOP(0);
-	/* ctx->sp will be set further down */
-
-	/* A context is compose of a fixed part and a variable part.
-	 * the variable part hold temporary varibles including arguments.
-	 *
-	 * Assuming a method context with 2 arguments and 3 local temporary
-	 * variables, the context will look like this.
-	 *   +---------------------+
-	 *   | fixed part          |
-	 *   |                     |
-	 *   |                     |
-	 *   |                     |
-	 *   +---------------------+
-	 *   | tmp1 (arg1)         | slot[0]
-	 *   | tmp2 (arg2)         | slot[1]
-	 *   | tmp3                | slot[2] 
-	 *   | tmp4                | slot[3]
-	 *   | tmp5                | slot[4]
-	 *   +---------------------+
-	 */
-
-	ctx->ntmprs = HCL_SMOOI_TO_OOP(ntmprs);
-	ctx->method_or_nargs = (hcl_oop_t)mth;
-	/* the 'home' field of a method context is always hcl->_nil.
-	ctx->home = hcl->_nil;*/
-	ctx->origin = ctx; /* point to self */
-
-	/* 
-	 * Assume this message sending expression:
-	 *   obj1 do: #this with: #that with: #it
-	 * 
-	 * It would be compiled to these logical byte-code sequences shown below:
-	 *   push obj1
-	 *   push #this
-	 *   push #that
-	 *   push #it
-	 *   send #do:with:
-	 *
-	 * After three pushes, the stack looks like this.
-	 * 
-	 *  | #it   | <- sp
-	 *  | #that |    sp - 1  
-	 *  | #this |    sp - 2
-	 *  | obj1  |    sp - nargs
-	 *
-	 * Since the number of arguments is 3, stack[sp - 3] points to
-	 * the receiver. When the stack is empty, sp is -1.
-	 */
-	for (i = nargs; i > 0; )
-	{
-		/* copy argument */
-		ctx->slot[--i] = HCL_STACK_GETTOP (hcl);
-		HCL_STACK_POP (hcl);
-	}
-	/* copy receiver */
-	ctx->receiver_or_source = HCL_STACK_GETTOP (hcl);
-	HCL_STACK_POP (hcl);
-
-	HCL_ASSERT (hcl->sp >= -1);
-
-	/* the stack pointer in a context is a stack pointer of a process 
-	 * before it is activated. this stack pointer is stored to the context
-	 * so that it is used to restore the process stack pointer upon returning
-	 * from a method context. */
-	ctx->sp = HCL_SMOOI_TO_OOP(hcl->sp);
-
-	/* switch the active context to the newly instantiated one*/
-	SWITCH_ACTIVE_CONTEXT (hcl, ctx);
-
-	return 0;
-}
-
 static int start_initial_process_and_context (hcl_t* hcl)
 {
 	hcl_oop_context_t ctx;
@@ -1147,25 +1069,10 @@ static int start_initial_process_and_context (hcl_t* hcl)
 	hcl_poptmp (hcl);
 	if (!proc) return -1;
 
-
-#if 0
-	HCL_STACK_PUSH (hcl, ass->value); /* push the receiver - the object referenced by 'objname' */
-	STORE_ACTIVE_SP (hcl); /* hcl->active_context->sp = HCL_SMOOI_TO_OOP(hcl->sp) */
-
-	HCL_ASSERT (hcl->processor->active == proc);
-	HCL_ASSERT (hcl->processor->active->initial_context == ctx);
-	HCL_ASSERT (hcl->processor->active->current_context == ctx);
-	HCL_ASSERT (hcl->active_context == ctx);
-
-	/* emulate the message sending */
-	return activate_new_method (hcl, mth);
-#else
 	HCL_STACK_PUSH (hcl, (hcl_oop_t)ctx);
 	STORE_ACTIVE_SP (hcl); /* hcl->active_context->sp = HCL_SMOOI_TO_OOP(hcl->sp) */
 
 	return activate_context (hcl, 0);
-#endif
-	
 }
 
 /* ------------------------------------------------------------------------- */
@@ -1183,6 +1090,10 @@ static int execute (hcl_t* hcl)
 	hcl_uintmax_t inst_counter = 0;
 #endif
 
+#if defined(HCL_DEBUG_VM_EXEC)
+	hcl_ooi_t fetched_instruction_pointer;
+#endif
+
 	HCL_ASSERT (hcl->active_context != HCL_NULL);
 
 	vm_startup (hcl);
@@ -1190,7 +1101,7 @@ static int execute (hcl_t* hcl)
 
 	while (1)
 	{
-#if 0 /* XXX */
+
 		if (hcl->sem_heap_count > 0)
 		{
 			hcl_ntime_t ft, now;
@@ -1286,17 +1197,10 @@ if (there is semaphore awaited.... )
 #endif
 
 		hcl->proc_switched = 0;
-#else
-	/* TODO: XXX this part is temporary. use if 0 part */
-	if (hcl->processor->active == hcl->nil_process) 
-	{
-		/* no more waiting semaphore and no more process */
-		HCL_ASSERT (hcl->processor->tally = HCL_SMOOI_TO_OOP(0));
-		HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG, "No more runnable process\n");
-		break;
-	}
-#endif /* END XXX */
 
+#if defined(HCL_DEBUG_VM_EXEC)
+		fetched_instruction_pointer = hcl->ip;
+#endif
 		FETCH_BYTE_CODE_TO (hcl, bcode);
 		/*while (bcode == HCL_CODE_NOOP) FETCH_BYTE_CODE_TO (hcl, bcode);*/
 
@@ -1630,11 +1534,31 @@ return -1;
 			case HCL_CODE_CALL_1:
 			case HCL_CODE_CALL_2:
 			case HCL_CODE_CALL_3:
+			{
+				hcl_oop_t rcv;
+
 			handle_call:
 				b1 = bcode & 0x3; /* low 2 bits */
 				LOG_INST_1 (hcl, "call %zu", b1);
-				/* TODO: CALL */
+
+				rcv = HCL_STACK_GETRCV (hcl, b1);
+				if (HCL_IS_CONTEXT(hcl, rcv))
+				{
+					if (activate_context (hcl, b1) <= -1) return -1;
+				}
+				else if (HCL_IS_PRIM(hcl, rcv))
+				{
+					if (call_primitive (hcl, b1) <= -1) return -1;
+				}
+				else
+				{
+					/* run time error */
+					HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_ERROR, "Error - cannot call %O\n", rcv);
+					hcl->errnum = HCL_ECALL;
+					return -1;
+				}
 				break;
+			}
 			
 			/* -------------------------------------------------------- */
 

hcl/lib/gc.c

@@ -500,7 +500,6 @@ int hcl_ignite (hcl_t* hcl)
 		*(hcl_oop_t*)((hcl_uint8_t*)hcl + syminfo[i].offset) = tmp;
 	}
 
-
 	if (!hcl->nil_process)
 	{
 		/* Create a nil process used to simplify nil check in GC.
@@ -520,7 +519,7 @@ int hcl_ignite (hcl_t* hcl)
 
 	if (!hcl->code.bc.arr)
 	{
-		hcl->code.bc.arr = hcl_makengcbytearray (hcl, HCL_NULL, 20000); /* TODO: set a proper intial size */
+		hcl->code.bc.arr = (hcl_oop_byte_t)hcl_makengcbytearray (hcl, HCL_NULL, 20000); /* TODO: set a proper intial size */
 		if (!hcl->code.bc.arr) return -1;
 	}
 

hcl/lib/hcl-cfg.h.in

@@ -66,6 +66,9 @@
 /* Define to 1 if you have the `getcontext' function. */
 #undef HAVE_GETCONTEXT
 
+/* Define to 1 if you have the `getitimer' function. */
+#undef HAVE_GETITIMER
+
 /* Define to 1 if you have the `gettimeofday' function. */
 #undef HAVE_GETTIMEOFDAY
 
@@ -96,6 +99,9 @@
 /* Define to 1 if you have the `setcontext' function. */
 #undef HAVE_SETCONTEXT
 
+/* Define to 1 if you have the `setitimer' function. */
+#undef HAVE_SETITIMER
+
 /* Define to 1 if you have the `settimeofday' function. */
 #undef HAVE_SETTIMEOFDAY
 

hcl/lib/hcl-prv.h

@@ -54,6 +54,10 @@
 #define HCL_DEBUG_GC
 #define HCL_DEBUG_VM_EXEC
 
+/* allow the caller to drive process switching by calling
+ * stix_switchprocess(). */
+#define HCL_EXTERNAL_PROCESS_SWITCH
+
 /* limit the maximum object size such that:
  *   1. an index to an object field can be represented in a small integer.
  *   2. the maximum number of bits including bit-shifts can be represented
@@ -1077,11 +1081,10 @@ HCL_EXPORT int hcl_compile (
 );
 
 /* ========================================================================= */
-/* exec.c                                                                    */
+/* prim.c                                                                    */
 /* ========================================================================= */
-int hcl_getprimno (
+int hcl_addbuiltinprims (
-	hcl_t*            hcl,
+	hcl_t*         hcl
-	const hcl_oocs_t* name
 );
 
 /* TODO: remove debugging functions */

hcl/lib/hcl.h

@@ -62,7 +62,10 @@ enum hcl_errnum_t
 	HCL_EIOERR,   /**< I/O error */
 	HCL_EECERR,   /**< encoding conversion error */
 	HCL_EFINIS,   /**< end of data/input/stream/etc */
-	HCL_ESYNERR  /** < syntax error */
+	HCL_ESYNERR,  /**< syntax error */
+	HCL_ECALL,    /**< runtime error - cannot call */
+	HCL_ERECALL,  /**< runtime error - cannot call again */
+	HCL_ECALLARG  /**< runtime error - wrong number of arguments to call */
 };
 typedef enum hcl_errnum_t hcl_errnum_t;
 
@@ -466,80 +469,6 @@ struct hcl_class_t
 #define HCL_CLASS_MTHDIC_CLASS    1
 
 
-#if defined(HCL_USE_OBJECT_TRAILER)
-#	define HCL_METHOD_NAMED_INSTVARS 8
-#else
-#	define HCL_METHOD_NAMED_INSTVARS 9
-#endif
-typedef struct hcl_method_t hcl_method_t;
-typedef struct hcl_method_t* hcl_oop_method_t;
-struct hcl_method_t
-{
-	HCL_OBJ_HEADER;
-
-	hcl_oop_class_t owner; /* Class */
-
-	hcl_oop_char_t  name; /* Symbol, method name */
-
-	/* primitive number */
-	hcl_oop_t       preamble; /* SmallInteger */
-
-	hcl_oop_t       preamble_data[2]; /* SmallInteger */
-
-	/* number of temporaries including arguments */
-	hcl_oop_t       tmpr_count; /* SmallInteger */
-
-	/* number of arguments in temporaries */
-	hcl_oop_t       tmpr_nargs; /* SmallInteger */
-
-#if defined(HCL_USE_OBJECT_TRAILER)
-	/* no code field is used */
-#else
-	hcl_oop_byte_t  code; /* ByteArray */
-#endif
-
-	hcl_oop_t       source; /* TODO: what should I put? */
-
-	/* == variable indexed part == */
-	hcl_oop_t       slot[1]; /* it stores literals */
-};
-
-/* The preamble field is composed of a 8-bit code and a 16-bit
- * index. 
- *
- * The code can be one of the following values:
- *  0 - no special action
- *  1 - return self
- *  2 - return nil
- *  3 - return true
- *  4 - return false 
- *  5 - return index.
- *  6 - return -index.
- *  7 - return instvar[index] 
- *  8 - do primitive[index]
- *  9 - do named primitive[index]
- * 10 - exception handler
- */
-#define HCL_METHOD_MAKE_PREAMBLE(code,index)  ((((hcl_ooi_t)index) << 8) | ((hcl_ooi_t)code))
-#define HCL_METHOD_GET_PREAMBLE_CODE(preamble) (((hcl_ooi_t)preamble) & 0xFF)
-#define HCL_METHOD_GET_PREAMBLE_INDEX(preamble) (((hcl_ooi_t)preamble) >> 8)
-
-#define HCL_METHOD_PREAMBLE_NONE            0
-#define HCL_METHOD_PREAMBLE_RETURN_RECEIVER 1
-#define HCL_METHOD_PREAMBLE_RETURN_NIL      2
-#define HCL_METHOD_PREAMBLE_RETURN_TRUE     3
-#define HCL_METHOD_PREAMBLE_RETURN_FALSE    4
-#define HCL_METHOD_PREAMBLE_RETURN_INDEX    5
-#define HCL_METHOD_PREAMBLE_RETURN_NEGINDEX 6
-#define HCL_METHOD_PREAMBLE_RETURN_INSTVAR  7
-#define HCL_METHOD_PREAMBLE_PRIMITIVE       8
-#define HCL_METHOD_PREAMBLE_NAMED_PRIMITIVE 9 /* index is an index to the symbol table */
-#define HCL_METHOD_PREAMBLE_EXCEPTION       10
-
-/* the index is an 16-bit unsigned integer. */
-#define HCL_METHOD_PREAMBLE_INDEX_MIN 0x0000
-#define HCL_METHOD_PREAMBLE_INDEX_MAX 0xFFFF
-#define HCL_OOI_IN_PREAMBLE_INDEX_RANGE(num) ((num) >= HCL_METHOD_PREAMBLE_INDEX_MIN && (num) <= HCL_METHOD_PREAMBLE_INDEX_MAX)
 
 #define HCL_CONTEXT_NAMED_INSTVARS 8
 typedef struct hcl_context_t hcl_context_t;
@@ -1031,8 +960,7 @@ enum hcl_log_mask_t
 	HCL_LOG_MNEMONIC  = (1 << 8),  /* bytecode mnemonic */
 	HCL_LOG_GC        = (1 << 9),
 	HCL_LOG_IC        = (1 << 10), /* instruction cycle, fetch-decode-execute */
-	HCL_LOG_PRIMITIVE = (1 << 11),
+	HCL_LOG_APP       = (1 << 11)  /* hcl applications, set by hcl logging primitive */
-	HCL_LOG_APP       = (1 << 12) /* hcl applications, set by hcl logging primitive */
 };
 typedef enum hcl_log_mask_t hcl_log_mask_t;
 
@@ -1059,7 +987,6 @@ typedef enum hcl_log_mask_t hcl_log_mask_t;
 #define HCL_INFO4(hcl,fmt,a1,a2,a3,a4) HCL_LOG4(hcl, HCL_LOG_INFO, fmt, a1, a2, a3, a4)
 #define HCL_INFO5(hcl,fmt,a1,a2,a3,a4,a5) HCL_LOG5(hcl, HCL_LOG_INFO, fmt, a1, a2, a3, a4, a5
 
-
 /* =========================================================================
  * HCL COMMON OBJECTS
  * ========================================================================= */
@@ -1079,6 +1006,7 @@ enum
 	HCL_BRAND_SET,
 
 	HCL_BRAND_CFRAME,/* compiler frame */
+	HCL_BRAND_PRIM,
 
 	HCL_BRAND_CONTEXT,
 	HCL_BRAND_PROCESS,
@@ -1114,6 +1042,8 @@ typedef struct hcl_cons_t* hcl_oop_cons_t;
 #define HCL_IS_CONS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONS)
 #define HCL_IS_ARRAY(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_ARRAY)
 
+#define HCL_IS_PRIM(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PRIM)
+
 #define HCL_CONS_CAR(v)  (((hcl_cons_t*)(v))->car)
 #define HCL_CONS_CDR(v)  (((hcl_cons_t*)(v))->cdr)
 
@@ -1121,6 +1051,8 @@ typedef struct hcl_cons_t* hcl_oop_cons_t;
 extern "C" {
 #endif
 
+#define hcl_switchprocess(hcl) ((hcl)->switch_proc = 1)
+
 HCL_EXPORT hcl_t* hcl_open (
 	hcl_mmgr_t*         mmgr,
 	hcl_oow_t           xtnsize,
@@ -1456,6 +1388,13 @@ HCL_EXPORT hcl_oop_t hcl_reversecons (
 	hcl_oop_t        cons
 );
 
+HCL_EXPORT hcl_oop_t hcl_makeprim (
+	hcl_t*          hcl,
+	hcl_prim_impl_t primimpl,
+	hcl_oow_t       minargs,
+	hcl_oow_t       maxargs
+);
+
 #if defined(__cplusplus)
 }
 #endif

hcl/lib/logfmt.c

@@ -272,6 +272,7 @@ static int put_oocs (hcl_t* hcl, hcl_oow_t mask, const hcl_ooch_t* ptr, hcl_oow_
 	hcl->log.len += len;
 
 	hcl->log.last_mask = mask;
+
 	return 1; /* success */
 }
 

hcl/lib/main.c

@@ -35,20 +35,36 @@
 #if defined(_WIN32)
 #	include <windows.h>
 #	include <tchar.h>
+#	if defined(STIX_HAVE_CFG_H)
+#		include <ltdl.h>
+#		define USE_LTDL
+#	endif
 #elif defined(__OS2__)
 #	define INCL_DOSMODULEMGR
 #	define INCL_DOSPROCESS
 #	define INCL_DOSERRORS
 #	include <os2.h>
 #elif defined(__MSDOS__)
-	/* nothing to include */
+#	include <dos.h>
-#	include <time.h>
 #elif defined(macintosh)
-	/* nothing to include */
+#	include <Timer.h>
 #else
+#	include <errno.h>
 #	include <unistd.h>
+#	include <ltdl.h>
+#	define USE_LTDL
+
+#	if defined(HAVE_TIME_H)
 #		include <time.h>
 #	endif
+#	if defined(HAVE_SYS_TIME_H)
+#		include <sys/time.h>
+#	endif
+#	if defined(HAVE_SIGNAL_H)
+#		include <signal.h>
+#	endif
+#endif
+
 
 typedef struct bb_t bb_t;
 struct bb_t
@@ -337,10 +353,10 @@ static int write_all (int fd, const char* ptr, hcl_oow_t len)
 
 		if (wr <= -1)
 		{
-			/*if (errno == EAGAIN || errno == EWOULDBLOCK)
+			if (errno == EAGAIN || errno == EWOULDBLOCK)
 			{
-				push it to internal buffers? before writing data just converted, need to write buffered data first.
+				continue;
-			}*/
+			}
 			return -1;
 		}
 
@@ -360,27 +376,30 @@ static void log_write (hcl_t* hcl, hcl_oow_t mask, const hcl_ooch_t* msg, hcl_oo
 	hcl_bch_t buf[256];
 	hcl_oow_t ucslen, bcslen, msgidx;
 	int n;
+	char ts[64];
+	size_t tslen;
+	struct tm tm, *tmp;
+	time_t now;
+
 
 if (mask & HCL_LOG_GC) return; /* don't show gc logs */
 
 /* TODO: beautify the log message.
  *       do classification based on mask. */
 
-{
-	char ts[32];
-	struct tm tm, *tmp;
-	time_t now;
-
 	now = time(NULL);
 #if defined(__MSDOS__)
 	tmp = localtime (&now);
 #else
 	tmp = localtime_r (&now, &tm);
 #endif
-	strftime (ts, sizeof(ts), "%Y-%m-%d %H:%M:%S %z ", tmp);
+	tslen = strftime (ts, sizeof(ts), "%Y-%m-%d %H:%M:%S %z ", tmp);
-
+	if (tslen == 0) 
-	write_all (1, ts, strlen(ts));
+	{
+		strcpy (ts, "0000-00-00 00:00:00 +0000");
+		tslen = 25; 
 	}
+	if (write_all (1, ts, tslen) <= -1) write (1, "XXXX ", 5);
 
 	msgidx = 0;
 	while (len > 0)
@@ -418,6 +437,121 @@ if (mask & HCL_LOG_GC) return; /* don't show gc logs */
 #endif
 }
 
+/* ========================================================================= */
+
+static hcl_t* g_hcl = HCL_NULL;
+
+/* ========================================================================= */
+
+
+#if defined(__MSDOS__) && defined(_INTELC32_)
+static void (*prev_timer_intr_handler) (void);
+
+#pragma interrupt(timer_intr_handler)
+static void timer_intr_handler (void)
+{
+	/*
+	_XSTACK *stk;
+	int r;
+	stk = (_XSTACK *)_get_stk_frame();
+	r = (unsigned short)stk_ptr->eax;   
+	*/
+
+	/* The timer interrupt (normally) occurs 18.2 times per second. */
+	if (g_hcl) hcl_switchprocess (g_hcl);
+	_chain_intr(prev_timer_intr_handler);
+}
+
+#elif defined(macintosh)
+
+static TMTask g_tmtask;
+static ProcessSerialNumber g_psn;
+
+#define TMTASK_DELAY 50 /* milliseconds if positive, microseconds(after negation) if negative */
+
+static pascal void timer_intr_handler (TMTask* task)
+{
+	if (g_hcl) hcl_switchprocess (g_hcl);
+	WakeUpProcess (&g_psn);
+	PrimeTime ((QElem*)&g_tmtask, TMTASK_DELAY);
+}
+
+#else
+static void arrange_process_switching (int sig)
+{
+	if (g_hcl) hcl_switchprocess (g_hcl);
+}
+#endif
+
+static void setup_tick (void)
+{
+#if defined(__MSDOS__) && defined(_INTELC32_)
+
+	prev_timer_intr_handler = _dos_getvect (0x1C);
+	_dos_setvect (0x1C, timer_intr_handler);
+
+#elif defined(macintosh)
+
+	GetCurrentProcess (&g_psn);
+	memset (&g_tmtask, 0, HCL_SIZEOF(g_tmtask));
+	g_tmtask.tmAddr = NewTimerProc (timer_intr_handler);
+	InsXTime ((QElem*)&g_tmtask);
+
+	PrimeTime ((QElem*)&g_tmtask, TMTASK_DELAY);
+
+#elif defined(HAVE_SETITIMER) && defined(SIGVTALRM) && defined(ITIMER_VIRTUAL)
+	struct itimerval itv;
+	struct sigaction act;
+
+	sigemptyset (&act.sa_mask);
+	act.sa_handler = arrange_process_switching;
+	act.sa_flags = 0;
+	sigaction (SIGVTALRM, &act, HCL_NULL);
+
+	itv.it_interval.tv_sec = 0;
+	itv.it_interval.tv_usec = 100; /* 100 microseconds */
+	itv.it_value.tv_sec = 0;
+	itv.it_value.tv_usec = 100;
+	setitimer (ITIMER_VIRTUAL, &itv, HCL_NULL);
+#else
+
+#	error UNSUPPORTED
+#endif
+}
+
+static void cancel_tick (void)
+{
+#if defined(__MSDOS__) && defined(_INTELC32_)
+
+	_dos_setvect (0x1C, prev_timer_intr_handler);
+
+#elif defined(macintosh)
+	RmvTime ((QElem*)&g_tmtask);
+	/*DisposeTimerProc (g_tmtask.tmAddr);*/
+
+#elif defined(HAVE_SETITIMER) && defined(SIGVTALRM) && defined(ITIMER_VIRTUAL)
+	struct itimerval itv;
+	struct sigaction act;
+
+	itv.it_interval.tv_sec = 0;
+	itv.it_interval.tv_usec = 0;
+	itv.it_value.tv_sec = 0; /* make setitimer() one-shot only */
+	itv.it_value.tv_usec = 0;
+	setitimer (ITIMER_VIRTUAL, &itv, HCL_NULL);
+
+	sigemptyset (&act.sa_mask); 
+	act.sa_handler = SIG_IGN; /* ignore the signal potentially fired by the one-shot arrange above */
+	act.sa_flags = 0;
+	sigaction (SIGVTALRM, &act, HCL_NULL);
+
+#else
+#	error UNSUPPORTED
+#endif
+}
+
+/* ========================================================================= */
+
+
 /* ========================================================================= */
 
 
@@ -556,6 +690,13 @@ int main (int argc, char* argv[])
 		return -1;
 	}
 
+	if (hcl_addbuiltinprims(hcl) <= -1)
+	{
+		printf ("cannot add builtin primitives - %d\n", hcl_geterrnum(hcl));
+		hcl_close (hcl);
+		return -1;
+	}
+
 	xtn = hcl_getxtn (hcl);
 
 #if defined(macintosh)
@@ -623,10 +764,14 @@ int main (int argc, char* argv[])
 
 hcl_decode (hcl, 0, hcl->code.bc.len);
 HCL_LOG0 (hcl, HCL_LOG_MNEMONIC, "------------------------------------------\n");
+g_hcl = hcl;
+setup_tick ();
 if (hcl_execute (hcl) <= -1)
 {
 	printf ("ERROR: cannot execute - %d\n", hcl_geterrnum(hcl));
 }
+cancel_tick();
+g_hcl = HCL_NULL;
 
 
 {

hcl/lib/obj.c

@@ -429,7 +429,6 @@ hcl_oop_t hcl_makeset (hcl_t* hcl, hcl_oow_t inisize)
 
 
 
-
 /* ------------------------------------------------------------------------ *
  * NGC HANDLING
  * ------------------------------------------------------------------------ */

hcl/lib/prim.c

@@ -0,0 +1,191 @@
+/*
+ * $Id$
+ *
+    Copyright (c) 2014-2016 Chung, Hyung-Hwan. All rights reserved.
+
+    Redistribution and use in source and binary forms, with or without
+    modification, are permitted provided that the following conditions
+    are met:
+    1. Redistributions of source code must retain the above copyright
+       notice, this list of conditions and the following disclaimer.
+    2. Redistributions in binary form must reproduce the above copyright
+       notice, this list of conditions and the following disclaimer in the
+       documentation and/or other materials provided with the distribution.
+
+    THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
+    IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+    OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+    IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
+    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+    NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+    THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+#include "hcl-prv.h"
+
+struct prim_t
+{
+	hcl_oow_t minargs;
+	hcl_oow_t maxargs;
+	hcl_prim_impl_t impl;
+
+	hcl_oow_t namelen;
+	hcl_ooch_t name[10];
+	
+};
+typedef struct prim_t prim_t;
+
+/* ------------------------------------------------------------------------- */
+
+hcl_oop_t hcl_makeprim (hcl_t* hcl, hcl_prim_impl_t primimpl, hcl_oow_t minargs, hcl_oow_t maxargs)
+{
+	hcl_oop_word_t obj;
+
+	obj = (hcl_oop_word_t)hcl_allocwordobj (hcl, HCL_BRAND_PRIM, HCL_NULL, 3);
+	if (obj)
+	{
+		obj->slot[0] = (hcl_oow_t)primimpl;
+		obj->slot[1] = minargs;
+		obj->slot[2] = maxargs;
+	}
+
+	return (hcl_oop_t)obj;
+}
+
+/* ------------------------------------------------------------------------- */
+
+static void log_char_object (hcl_t* hcl, hcl_oow_t mask, hcl_oop_char_t msg)
+{
+	hcl_ooi_t n;
+	hcl_oow_t rem;
+	const hcl_ooch_t* ptr;
+
+	HCL_ASSERT (HCL_OBJ_GET_FLAGS_TYPE(msg) == HCL_OBJ_TYPE_CHAR);
+
+	rem = HCL_OBJ_GET_SIZE(msg);
+	ptr = msg->slot;
+
+start_over:
+	while (rem > 0)
+	{
+		if (*ptr == '\0') 
+		{
+			n = hcl_logbfmt (hcl, mask, "%C", *ptr);
+			HCL_ASSERT (n == 1);
+			rem -= n;
+			ptr += n;
+			goto start_over;
+		}
+
+		n = hcl_logbfmt (hcl, mask, "%.*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 = hcl_logbfmt (hcl, mask, "%C", *ptr);
+			HCL_ASSERT (n == 1);
+		}
+		rem -= n;
+		ptr += n;
+	}
+}
+
+static int prim_log (hcl_t* hcl, hcl_ooi_t nargs)
+{
+/* TODO: accept log level */
+	hcl_oop_t msg, level;
+	hcl_oow_t mask;
+	hcl_ooi_t k;
+
+	/*level = HCL_STACK_GET(hcl, hcl->sp - nargs + 1);
+	if (!HCL_OOP_IS_SMOOI(level)) mask = HCL_LOG_APP | HCL_LOG_INFO; 
+	else mask = HCL_LOG_APP | HCL_OOP_TO_SMOOI(level);*/
+	mask = HCL_LOG_APP | HCL_LOG_INFO; /* TODO: accept logging level .. */
+
+	for (k = 0; k < nargs; k++)
+	{
+		msg = HCL_STACK_GETARG (hcl, nargs, k);
+
+		if (msg == hcl->_nil || msg == hcl->_true || msg == hcl->_false) 
+		{
+			goto dump_object;
+		}
+		else if (HCL_OOP_IS_POINTER(msg))
+		{
+			if (HCL_OBJ_GET_FLAGS_TYPE(msg) == HCL_OBJ_TYPE_CHAR)
+			{
+				log_char_object (hcl, mask, (hcl_oop_char_t)msg);
+			}
+			else if (HCL_OBJ_GET_FLAGS_TYPE(msg) == HCL_OBJ_TYPE_OOP)
+			{
+				/* visit only 1-level down into an array-like object */
+				hcl_oop_t inner, _class;
+				hcl_oow_t i, spec;
+
+				_class = HCL_CLASSOF(hcl, msg);
+
+				spec = HCL_OOP_TO_SMOOI(((hcl_oop_class_t)_class)->spec);
+				if (HCL_CLASS_SPEC_NAMED_INSTVAR(spec) > 0 || !HCL_CLASS_SPEC_IS_INDEXED(spec)) goto dump_object;
+
+				for (i = 0; i < HCL_OBJ_GET_SIZE(msg); i++)
+				{
+					inner = ((hcl_oop_oop_t)msg)->slot[i];
+
+					if (i > 0) hcl_logbfmt (hcl, mask, " ");
+					if (HCL_OOP_IS_POINTER(inner) &&
+					    HCL_OBJ_GET_FLAGS_TYPE(inner) == HCL_OBJ_TYPE_CHAR)
+					{
+						log_char_object (hcl, mask, (hcl_oop_char_t)inner);
+					}
+					else
+					{
+						hcl_logbfmt (hcl, mask, "%O", inner);
+					}
+				}
+			}
+			else goto dump_object;
+		}
+		else
+		{
+		dump_object:
+			hcl_logbfmt (hcl, mask, "%O", msg);
+		}
+	}
+
+	HCL_STACK_SETRET (hcl, nargs, hcl->_nil);
+	return 0;
+}
+
+/* ------------------------------------------------------------------------- */
+
+static prim_t builtin_prims[] =
+{
+	{ 0, HCL_TYPE_MAX(hcl_oow_t), prim_log,   3,  { 'l','o','g' } }
+};
+
+
+int hcl_addbuiltinprims (hcl_t* hcl)
+{
+	hcl_oow_t i;
+	hcl_oop_t prim, name;
+
+	for (i = 0; i < HCL_COUNTOF(builtin_prims); i++)
+	{
+		prim = hcl_makeprim (hcl, builtin_prims[i].impl, builtin_prims[i].minargs, builtin_prims[i].maxargs);
+		if (!prim) return -1;
+
+		hcl_pushtmp (hcl, &prim);
+		name = hcl_makesymbol (hcl, builtin_prims[i].name, builtin_prims[i].namelen);
+		hcl_poptmp (hcl);
+		if (!name) return -1;
+
+		if (!hcl_putatsysdic (hcl, name, prim)) return -1;
+	}
+
+	return 0;
+}

hcl/lib/print.c

@@ -193,10 +193,11 @@ enum
 	WORD_NIL,
 	WORD_TRUE,
 	WORD_FALSE,
-
-
 	WORD_SET,
+
 	WORD_CFRAME,
+	WORD_PRIM,
+
 	WORD_CONTEXT,
 	WORD_PROCESS,
 	WORD_PROCESS_SCHEDULER,
@@ -215,6 +216,7 @@ static struct
 
 	{  6,  { '#','<','S','E','T','>' } },
 	{  9,  { '#','<','C','F','R','A','M','E','>' } },
+	{  7,  { '#','<','P','R','I','M','>' } },
 	{  10, { '#','<','C','O','N','T','E','X','T','>' } },
 	{  10, { '#','<','P','R','O','C','E','S','S','>' } },
 	{  20, { '#','<','P','R','O','C','E','S','S','-','S','C','H','E','D','U','L','E','R','>' } },
@@ -470,6 +472,10 @@ next:
 			OUTPUT_STRX (pr, word[WORD_CFRAME].ptr, word[WORD_CFRAME].len);
 			break;
 
+		case HCL_BRAND_PRIM:
+			OUTPUT_STRX (pr, word[WORD_PRIM].ptr, word[WORD_PRIM].len);
+			break;
+
 		case HCL_BRAND_CONTEXT:
 			OUTPUT_STRX (pr, word[WORD_CONTEXT].ptr, word[WORD_CONTEXT].len);
 			break;