added a test on process handling.

used hcl_instantiate() in making process-related objects

lib/dic.c

@@ -147,7 +147,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t k
 					hcl_oop_cons_t pair;
 					pair = (hcl_oop_cons_t)ass->cdr; /* once found, this must be a pair of method pointers  */
 					HCL_ASSERT (hcl, HCL_IS_CONS(hcl, pair));
-					HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, value));
+					HCL_ASSERT (hcl, HCL_IS_COMPILED_BLOCK(hcl, value));
 					if (is_method & 1) pair->car = value; /* class method */
 					if (is_method & 2) pair->cdr = value; /* instance method */
 					/* the class instantiation method goes to both cells.
@@ -221,7 +221,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t k
 	{
 		/* create a new pair that holds a class method at the first cell and an instance method at the second cell */
 		hcl_oop_t pair;
-		HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, value));
+		HCL_ASSERT (hcl, HCL_IS_COMPILED_BLOCK(hcl, value));
 		hcl_pushvolat (hcl, &key);
 		pair = hcl_makecons(hcl, (is_method & 1? value: hcl->_nil), (is_method & 2? value: hcl->_nil));
 		hcl_popvolat (hcl);

lib/exec.c

@@ -345,7 +345,6 @@ static HCL_INLINE void vm_gettime (hcl_t* hcl, hcl_ntime_t* now)
 	HCL_SUB_NTIME (now, now, &hcl->exec_start_time);  /* now = now - exec_start_time */
 }
 
-
 static HCL_INLINE int vm_sleep (hcl_t* hcl, const hcl_ntime_t* dur)
 {
 /* TODO: return 1 if it gets into the halting state */
@@ -374,7 +373,7 @@ static HCL_INLINE hcl_oop_context_t make_context (hcl_t* hcl, hcl_ooi_t ntmprs)
 	hcl_oop_context_t ctx;
 	HCL_ASSERT (hcl, ntmprs >= 0);
 	/*return (hcl_oop_context_t)hcl_allocoopobj(hcl, HCL_BRAND_CONTEXT, HCL_CONTEXT_NAMED_INSTVARS + (hcl_oow_t)ntmprs);*/
-	ctx =(hcl_oop_context_t)hcl_instantiatewithtrailer(hcl, hcl->c_block_context, ntmprs, HCL_NULL, 0);
+	ctx = (hcl_oop_context_t)hcl_instantiate(hcl, hcl->c_block_context, HCL_NULL, ntmprs);
 
 	/* TODO: a good way to initialize smooi field to 0 in hcl_insstantiate()?
 	 *      for this, there must be a way to specify the type of the member variables...
@@ -389,7 +388,7 @@ static HCL_INLINE hcl_oop_function_t make_function (hcl_t* hcl, hcl_oow_t lfsize
 	hcl_oop_function_t func;
 
 	/* the literal frame is placed in the variable part.
-	 * the byte code is placed in the trailer space */
+	 * the byte code is placed in the trailer space. */
 	/*func = (hcl_oop_function_t)hcl_allocoopobjwithtrailer(hcl, HCL_BRAND_FUNCTION, HCL_FUNCTION_NAMED_INSTVARS + lfsize, bptr, blen);*/
 	func = (hcl_oop_function_t)hcl_instantiatewithtrailer(hcl, hcl->c_function, lfsize, bptr, blen);
 	if (HCL_UNLIKELY(!func)) return HCL_NULL;
@@ -430,11 +429,11 @@ static HCL_INLINE void fill_function_data (hcl_t* hcl, hcl_oop_function_t func,
 	func->attr_mask = HCL_SMOOI_TO_OOP(attr_mask);
 }
 
-static HCL_INLINE hcl_oop_block_t make_block (hcl_t* hcl)
+static HCL_INLINE hcl_oop_block_t make_compiled_block (hcl_t* hcl)
 {
 	/* create a base block used for creation of a block context */
 	/*return (hcl_oop_block_t)hcl_allocoopobj(hcl, HCL_BRAND_BLOCK, HCL_BLOCK_NAMED_INSTVARS);*/
-	return (hcl_oop_block_t)hcl_instantiate(hcl, hcl->c_block, HCL_NULL, 0);
+	return (hcl_oop_block_t)hcl_instantiate(hcl, hcl->c_compiled_block, HCL_NULL, 0);
 }
 
 static HCL_INLINE void fill_block_data (hcl_t* hcl, hcl_oop_block_t blk, hcl_ooi_t attr_mask, hcl_ooi_t ip, hcl_oop_context_t homectx)
@@ -559,9 +558,15 @@ static hcl_oop_process_t make_process (hcl_t* hcl, hcl_oop_context_t c)
 	else if (clstksize < 32) clstksize = 32;
 
 	hcl_pushvolat (hcl, (hcl_oop_t*)&c);
-	proc = (hcl_oop_process_t)hcl_allocoopobj(hcl, HCL_BRAND_PROCESS, HCL_PROCESS_NAMED_INSTVARS + stksize + exstksize + clstksize);
+	/*proc = (hcl_oop_process_t)hcl_allocoopobj(hcl, HCL_BRAND_PROCESS, HCL_PROCESS_NAMED_INSTVARS + stksize + exstksize + clstksize);*/
+	proc = (hcl_oop_process_t)hcl_instantiate(hcl, hcl->c_process, HCL_NULL, stksize + exstksize + clstksize);
 	hcl_popvolat (hcl);
-	if (HCL_UNLIKELY(!proc)) return HCL_NULL;
+	if (HCL_UNLIKELY(!proc))
+	{
+		const hcl_ooch_t* oldmsg = hcl_backuperrmsg(hcl);
+		hcl_seterrbfmt (hcl, hcl->errnum, "unable to make process - %js", oldmsg);
+		return HCL_NULL;
+	}
 
 #if 0
 ////////////////////
@@ -1101,7 +1106,6 @@ static void suspend_process (hcl_t* hcl, hcl_oop_process_t proc)
 			hcl_oop_process_t nrp;
 
 			nrp = find_next_runnable_process(hcl);
-
 			if (nrp == proc)
 			{
 				/* no runnable process after suspension */
@@ -1140,10 +1144,10 @@ static void yield_process (hcl_t* hcl, hcl_oop_process_t proc)
 	if (proc->state == HCL_SMOOI_TO_OOP(HCL_PROCESS_STATE_RUNNING))
 	{
 		/* RUNNING --> RUNNABLE */
-
 		hcl_oop_process_t nrp;
 
 		HCL_ASSERT (hcl, proc == hcl->processor->active);
+		HCL_ASSERT (hcl, HCL_IS_PROCESS(hcl, proc));
 
 		nrp = find_next_runnable_process(hcl);
 		/* if there are more than 1 runnable processes, the next
@@ -1912,7 +1916,7 @@ static int prepare_new_context (hcl_t* hcl, hcl_oop_block_t op_blk, hcl_ooi_t na
 	hcl_ooi_t fixed_nargs, actual_nargs, excess_nargs;
 
 	/* the receiver must be a block context */
-	HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, op_blk));
+	HCL_ASSERT (hcl, HCL_IS_COMPILED_BLOCK(hcl, op_blk));
 
 	attr_mask = HCL_OOP_TO_SMOOI(op_blk->attr_mask);
 
@@ -2005,7 +2009,7 @@ static HCL_INLINE int __activate_block (hcl_t* hcl, hcl_oop_block_t op_blk, hcl_
 {
 	int x;
 
-	HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, op_blk));
+	HCL_ASSERT (hcl, HCL_IS_COMPILED_BLOCK(hcl, op_blk));
 
 	x = prepare_new_context(
 		hcl,
@@ -2032,7 +2036,7 @@ static HCL_INLINE int activate_block (hcl_t* hcl, hcl_ooi_t nargs, hcl_ooi_t nrv
 	int x;
 
 	op_blk = (hcl_oop_block_t)HCL_STACK_GETOP(hcl, nargs);
-	HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, op_blk));
+	HCL_ASSERT (hcl, HCL_IS_COMPILED_BLOCK(hcl, op_blk));
 
 	x = __activate_block(hcl, op_blk, nargs, nrvars, 0, 0, &newctx);
 	if (HCL_UNLIKELY(x <= -1)) return -1;
@@ -3775,7 +3779,7 @@ static int execute (hcl_t* hcl)
 				LOG_INST_2 (hcl, "call %zu %zu", b1, b2);
 
 				rcv = HCL_STACK_GETOP(hcl, b1);
-				if (HCL_IS_BLOCK(hcl, rcv))
+				if (HCL_IS_COMPILED_BLOCK(hcl, rcv))
 				{
 					if (activate_block(hcl, b1, b2) <= -1) goto call2_failed;
 					break;
@@ -4787,7 +4791,7 @@ hcl_logbfmt (hcl, HCL_LOG_STDERR, ">>>%O c->sc=%O sc=%O b2=%d b3=%d nivars=%d nc
 
 				HCL_ASSERT (hcl, b1 >= 0);
 
-				blkobj = make_block(hcl);
+				blkobj = make_compiled_block(hcl);
 				if (HCL_UNLIKELY(!blkobj)) goto oops;
 
 				/* the long forward jump instruction has the format of
@@ -4954,9 +4958,9 @@ hcl_pfrc_t hcl_pf_process_fork (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
 	int x;
 
 	blk = (hcl_oop_block_t)HCL_STACK_GETARG(hcl, nargs, 0);
-	if (!HCL_IS_BLOCK(hcl, blk))
+	if (!HCL_IS_COMPILED_BLOCK(hcl, blk))
 	{
-		hcl_seterrbfmt (hcl, HCL_EINVAL, "parameter not block - %O", blk);
+		hcl_seterrbfmt (hcl, HCL_EINVAL, "parameter not compiled block - %O", blk);
 		return HCL_PF_FAILURE;
 	}
 
@@ -5068,8 +5072,14 @@ hcl_pfrc_t hcl_pf_semaphore_new (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
 {
 	hcl_oop_semaphore_t sem;
 
-	sem = (hcl_oop_semaphore_t)hcl_allocoopobj(hcl, HCL_BRAND_SEMAPHORE, HCL_SEMAPHORE_NAMED_INSTVARS);
+	/*sem = (hcl_oop_semaphore_t)hcl_allocoopobj(hcl, HCL_BRAND_SEMAPHORE, HCL_SEMAPHORE_NAMED_INSTVARS);*/
-	if (HCL_UNLIKELY(!sem)) return  HCL_PF_FAILURE;
+	sem = (hcl_oop_semaphore_t)hcl_instantiate(hcl, hcl->c_semaphore, HCL_NULL, 0);
+	if (HCL_UNLIKELY(!sem))
+	{
+		const hcl_ooch_t* oldmsg = hcl_backuperrmsg(hcl);
+		hcl_seterrbfmt (hcl, hcl->errnum, "unable to make semaphore - %js", oldmsg);
+		return HCL_PF_FAILURE;
+	}
 
 	sem->count = HCL_SMOOI_TO_OOP(0);
 /* TODO: sem->signal_action? */
@@ -5355,8 +5365,14 @@ hcl_pfrc_t hcl_pf_semaphore_group_new (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nar
 {
 	hcl_oop_semaphore_group_t sg;
 
-	sg = (hcl_oop_semaphore_group_t)hcl_allocoopobj(hcl, HCL_BRAND_SEMAPHORE_GROUP, HCL_SEMAPHORE_GROUP_NAMED_INSTVARS);
+	/*sg = (hcl_oop_semaphore_group_t)hcl_allocoopobj(hcl, HCL_BRAND_SEMAPHORE_GROUP, HCL_SEMAPHORE_GROUP_NAMED_INSTVARS);*/
-	if (HCL_UNLIKELY(!sg)) return  HCL_PF_FAILURE;
+	sg = (hcl_oop_semaphore_group_t)hcl_instantiate(hcl, hcl->c_semaphore_group, HCL_NULL, 0);
+	if (HCL_UNLIKELY(!sg))
+	{
+		const hcl_ooch_t* oldmsg = hcl_backuperrmsg(hcl);
+		hcl_seterrbfmt (hcl, hcl->errnum, "unable to make semaphore group - %js", oldmsg);
+		return HCL_PF_FAILURE;
+	}
 
 	sg->sem_io_count = HCL_SMOOI_TO_OOP(0);
 	sg->sem_count = HCL_SMOOI_TO_OOP(0);

lib/gc.c

@@ -469,7 +469,7 @@ static kernel_class_info_t kernel_classes[__KCI_MAX__] =
 		HCL_BLOCK_NAMED_INSTVARS,
 		0,
 		HCL_OBJ_TYPE_OOP,
-		HCL_OFFSETOF(hcl_t, c_block)
+		HCL_OFFSETOF(hcl_t, c_compiled_block)
 	},
 
 	KCI(KCI_BLOCK_CONTEXT) {

lib/hcl-prv.h

@@ -997,7 +997,7 @@ struct hcl_compiler_t
 		hcl_ooi_t depth; /* signed because it starts with -1 */
 		hcl_fnblk_info_t* info;
 		hcl_oow_t  info_capa;
-	} fnblk; /* lambda/function block */
+	} fnblk; /* function block */
 
 	struct
 	{
@@ -1594,14 +1594,6 @@ hcl_oop_cons_t hcl_putatdic_method (
 	int           mtype /* 1 for class method, 2 for instance method */
 );
 
-
-/* ========================================================================= */
-/* proc.c                                                                    */
-/* ========================================================================= */
-hcl_oop_process_t hcl_makeproc (
-	hcl_t* hcl
-);
-
 /* ========================================================================= */
 /* gc.c                                                                    */
 /* ========================================================================= */

lib/hcl.h

@@ -1735,7 +1735,7 @@ struct hcl_t
 #endif
 	hcl_oop_class_t c_function; /* Function */
 	hcl_oop_class_t c_primitive; /* Primitive */
-	hcl_oop_class_t c_block; /* CompiledBlock */
+	hcl_oop_class_t c_compiled_block; /* CompiledBlock */
 
 	hcl_oop_class_t c_block_context; /* BlockContext */
 	hcl_oop_class_t c_process; /* Process */
@@ -2098,8 +2098,8 @@ typedef enum hcl_concode_t hcl_concode_t;
 /*#define HCL_IS_FUNCTION(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_FUNCTION)*/
 #define HCL_IS_FUNCTION(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_function)
 
-/*#define HCL_IS_BLOCK(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_BLOCK)*/
+/*#define HCL_IS_COMPILED_BLOCK(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_BLOCK)*/
-#define HCL_IS_BLOCK(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_block)
+#define HCL_IS_COMPILED_BLOCK(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_compiled_block)
 
 /*#define HCL_IS_CLASS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CLASS)*/
 #define HCL_IS_CLASS(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_class)
@@ -2127,9 +2127,15 @@ typedef enum hcl_concode_t hcl_concode_t;
 #define HCL_IS_BIGINT(hcl,v) (HCL_OOP_IS_POINTER(v) && (HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PBIGINT || HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_NBIGINT))
 #define HCL_IS_FPDEC(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_FPDEC)
 
-#define HCL_IS_PROCESS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PROCESS)
+/*#define HCL_IS_PROCESS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PROCESS)*/
-#define HCL_IS_SEMAPHORE(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SEMAPHORE)
+#define HCL_IS_PROCESS(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_process)
-#define HCL_IS_SEMAPHORE_GROUP(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SEMAPHORE_GROUP)
+
+
+/*#define HCL_IS_SEMAPHORE(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SEMAPHORE)*/
+#define HCL_IS_SEMAPHORE(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_semaphore)
+
+/*#define HCL_IS_SEMAPHORE_GROUP(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SEMAPHORE_GROUP)*/
+#define HCL_IS_SEMAPHORE_GROUP(hcl,v) (HCL_CLASSOF(hcl,v) == (hcl_oop_t)hcl->c_semaphore_group)
 
 #define HCL_CONS_CAR(v)  (((hcl_cons_t*)(v))->car)
 #define HCL_CONS_CDR(v)  (((hcl_cons_t*)(v))->cdr)

lib/obj.c

@@ -173,14 +173,8 @@ hcl_oop_t hcl_allocoopobjwithtrailer (hcl_t* hcl, int brand, hcl_oow_t size, con
 	/* [NOTE] this is not converted to a SMOOI object */
 	hdr->slot[size] = (hcl_oop_t)blen;
 
-	if (bptr)
+	if (bptr) HCL_MEMCPY (&hdr->slot[size + 1], bptr, blen);
-	{
+	else HCL_MEMSET (&hdr->slot[size + 1], 0, blen);
-		HCL_MEMCPY (&hdr->slot[size + 1], bptr, blen);
-	}
-	else
-	{
-		HCL_MEMSET (&hdr->slot[size + 1], 0, blen);
-	}
 
 	return (hcl_oop_t)hdr;
 }
@@ -224,7 +218,7 @@ static HCL_INLINE hcl_oop_t alloc_numeric_array (hcl_t* hcl, int brand, const vo
 	else
 	{
 		/* initialize with zeros when the string pointer is not given */
-		HCL_MEMSET ((hdr + 1), 0, nbytes_aligned);
+		HCL_MEMSET (hdr + 1, 0, nbytes_aligned);
 	}
 
 	return hdr;

lib/prim.c

@@ -719,11 +719,11 @@ static hcl_pfrc_t pf_is_dictionary (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
 	return HCL_PF_SUCCESS;
 }
 
-static hcl_pfrc_t pf_is_block (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
+static hcl_pfrc_t pf_is_compiled_block (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
 {
 	hcl_oop_t rv, x;
 	x = HCL_STACK_GETARG(hcl, nargs, 0);
-	rv = (HCL_IS_BLOCK(hcl, x))? hcl->_true: hcl->_false;
+	rv = (HCL_IS_COMPILED_BLOCK(hcl, x))? hcl->_true: hcl->_false;
 	HCL_STACK_SETRET (hcl, nargs, rv);
 	return HCL_PF_SUCCESS;
 }
@@ -1281,8 +1281,7 @@ static pf_t builtin_prims[] =
 	{ 1, 1,                       pf_is_array,        6,  { 'a','r','r','a','y','?' } },
 	{ 1, 1,                       pf_is_bytearray,   10,  { 'b','y','t','e','a','r','r','a','y','?' } },
 	{ 1, 1,                       pf_is_dictionary,  11,  { 'd','i','c','t','i','o','n','a','r','y','?' } },
-	{ 1, 1,                       pf_is_block,        7,  { 'l','a','m','b','d','a','?' } },
+	{ 1, 1,                       pf_is_compiled_block, 4,  { 'f','u','n','?' } },
-	{ 1, 1,                       pf_is_block,        4,  { 'f','u','n','?' } },
 	{ 1, 1,                       pf_is_class,        6,  { 'c','l','a','s','s','?' } },
 	{ 1, 1,                       pf_is_object,       7,  { 'o','b','j','e','c','t','?' } },
 

t/Makefile.am

@@ -5,6 +5,7 @@ check_SCRIPTS = \
 	fun-01.hcl \
 	insta-01.hcl \
 	insta-02.hcl \
+	proc-01.hcl \
 	ret-01.hcl \
 	retvar-01.hcl \
 	va-01.hcl \

t/Makefile.in

@@ -477,6 +477,7 @@ check_SCRIPTS = \
 	fun-01.hcl \
 	insta-01.hcl \
 	insta-02.hcl \
+	proc-01.hcl \
 	ret-01.hcl \
 	retvar-01.hcl \
 	va-01.hcl \

t/proc-01.hcl

@@ -0,0 +1,50 @@
+z1 := 0
+z2 := 0
+
+defun loop1() {
+	| k |
+
+	k := 1
+	while (< k 100) {
+		printf "loop1 => %d\n" k
+		k := (+ k 2)
+		yield
+	}
+
+	z1 := k
+	sem-signal s1
+}
+
+defun loop2() {
+	| k |
+
+	k := 0
+	while (< k 100) {
+		printf "loop2 => %d\n" k
+		k := (+ k 2)
+		yield
+	}
+
+	z2 := k
+	sem-signal s2
+}
+
+s1 := (sem-new)
+s2 := (sem-new)
+
+p1 := (fork loop1)
+p2 := (fork loop2)
+
+##suspend p1
+##suspend p2
+##resume p1
+##resume p2
+
+sem-wait s1
+sem-wait s2
+
+if (== z1 101) { printf "OK: z1 is %d\n" z1 } \
+else { printf "ERROR: z1 is not 101 - %d\n" z1 }
+if (== z2 100) { printf "OK: z2 is %d\n" z2 } \
+else { printf "ERROR: z1 is not 100 - %d\n" z2 }
+