work in progress to add the hcl_purgeatdic() function

lib/comp.c

@@ -32,7 +32,6 @@ enum
 	VAR_INDEXED
 };
 
-#define CODE_BUFFER_ALIGN 1024 /* TODO: set a bigger value */
 #define TV_BUFFER_ALIGN 256
 #define BLK_TMPRCNT_BUFFER_ALIGN 128
 
@@ -64,8 +63,8 @@ static int add_literal (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t* index)
 		hcl_oop_t tmp;
 		hcl_oow_t newcapa;
 
-		newcapa = capa + 20000; /* TODO: set a better resizing policy */
+		newcapa = HCL_ALIGN(capa + 1, HCL_LIT_BUFFER_ALIGN);
-		tmp = hcl_remakengcarray (hcl, (hcl_oop_t)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 = (hcl_oop_oop_t)tmp;
@@ -179,7 +178,7 @@ static int emit_byte_instruction (hcl_t* hcl, hcl_oob_t bc)
 		hcl_oop_t tmp;
 		hcl_oow_t newcapa;
 
-		newcapa = HCL_ALIGN (capa + 1, CODE_BUFFER_ALIGN);
+		newcapa = HCL_ALIGN(capa + 1, HCL_BC_BUFFER_ALIGN);
 		tmp = hcl_remakengcbytearray (hcl, (hcl_oop_t)hcl->code.bc.arr, newcapa);
 		if (!tmp) return -1;
 
@@ -2535,10 +2534,10 @@ static HCL_INLINE int emit_set (hcl_t* hcl)
 
 		HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, cf->operand));
 
-		cons = (hcl_oop_t)hcl_getatsysdic (hcl, cf->operand);
+		cons = (hcl_oop_t)hcl_getatsysdic(hcl, cf->operand);
 		if (!cons) 
 		{
-			cons = (hcl_oop_t)hcl_putatsysdic (hcl, cf->operand, hcl->_nil);
+			cons = (hcl_oop_t)hcl_putatsysdic(hcl, cf->operand, hcl->_nil);
 			if (!cons) return -1;
 		}
 

lib/dic.c

@@ -33,7 +33,6 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc)
 	hcl_oop_oop_t newbuc;
 	hcl_oow_t oldsz, newsz, index;
 	hcl_oop_cons_t ass;
-	hcl_oop_char_t key;
 
 	oldsz = HCL_OBJ_GET_SIZE(oldbuc);
 
@@ -124,7 +123,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_cha
 		HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,ass->car));
 
 		if (HCL_OBJ_GET_SIZE(key) == HCL_OBJ_GET_SIZE(ass->car) &&
-		    hcl_equaloochars (key->slot, ((hcl_oop_char_t)ass->car)->slot, HCL_OBJ_GET_SIZE(key))) 
+		    hcl_equaloochars(key->slot, ((hcl_oop_char_t)ass->car)->slot, HCL_OBJ_GET_SIZE(key))) 
 		{
 			/* the value of HCL_NULL indicates no insertion or update. */
 			if (value) ass->cdr = value; /* update */
@@ -256,6 +255,97 @@ hcl_oop_cons_t hcl_getatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key)
 	return find_or_upsert (hcl, dic, (hcl_oop_char_t)key, HCL_NULL);
 }
 
+int hcl_purgeatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key)
+{
+	hcl_ooi_t tally;
+	hcl_oow_t hv, index, bs, i, x, y, z;
+	hcl_oop_cons_t ass;
+
+	tally = HCL_OOP_TO_SMOOI(dic->tally);
+	bs = HCL_OBJ_GET_SIZE(dic->bucket);
+
+	/* the system dictionary is not a generic dictionary.
+	 * it accepts only a symbol as a key. */
+#if defined(SYMBOL_ONLY_KEY)
+	HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
+#endif
+	HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(dic->tally));
+	HCL_ASSERT (hcl, HCL_IS_ARRAY(hcl,dic->bucket));
+
+#if defined(SYMBOL_ONLY_KEY)
+	index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % bs;
+#else
+	if (hcl_hashobj(hcl, (hcl_oop_t)key, &index) <= -1) return -1;
+	index %= bs;
+#endif
+
+	/* find */
+	while (dic->bucket->slot[index] != hcl->_nil) 
+	{
+	#if defined(SYMBOL_ONLY_KEY)
+		ass = (hcl_oop_cons_t)dic->bucket->slot[index];
+		HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass));
+		HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,ass->car));
+
+		if (HCL_OBJ_GET_SIZE(key) == HCL_OBJ_GET_SIZE(ass->car) &&
+		    hcl_equaloochars(key->slot, ((hcl_oop_char_t)ass->car)->slot, HCL_OBJ_GET_SIZE(key))) 
+		{
+			/* the value of HCL_NULL indicates no insertion or update. */
+			goto found;
+		}
+	#else
+		int n;
+
+		ass = (hcl_oop_cons_t)dic->bucket->slot[index];
+		HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass));
+
+		n = hcl_equalobjs(hcl, (hcl_oop_t)key, ass->car);
+		if (n <= -1) return -1;
+		if (n >= 1) goto found;
+	#endif
+
+		index = (index + 1) % HCL_OBJ_GET_SIZE(dic->bucket);
+	}
+
+	hcl_seterrnum (hcl, HCL_ENOENT);
+	return -1;
+
+found:
+	/* compact the cluster */
+	for (i = 0, x = index, y = index; i < tally; i++)
+	{
+		y = (y + 1) % bs;
+
+		/* done if the slot at the current index is empty */
+		if (dic->bucket->slot[y] == hcl->_nil) break;
+
+		ass = (hcl_oop_cons_t)dic->bucket->slot[y];
+	#if defined(SYMBOL_ONLY_KEY)
+		/* get the natural hash index for the data in the slot at
+		 * the current hash index */
+		z = hcl_hashoochars(((hcl_oop_char_t)ass->key)->slot, HCL_OBJ_GET_SIZE(ass->key)) % bs;
+	#else
+		if (hcl_hashobj(hcl, ass->car, &z) <= -1) return -1;
+		index %= bs;
+	#endif
+
+		/* move an element if necesary */
+		if ((y > x && (z <= x || z > y)) ||
+		    (y < x && (z <= x && z > y)))
+		{
+			dic->bucket->slot[x] = dic->bucket->slot[y];
+			x = y;
+		}
+	}
+
+	dic->bucket->slot[x] = hcl->_nil;
+
+	tally--;
+	dic->tally = HCL_SMOOI_TO_OOP(tally);
+
+	return 0;
+}
+
 hcl_oop_t hcl_makedic (hcl_t* hcl, hcl_oow_t inisize)
 {
 	hcl_oop_dic_t obj;

lib/gc.c

@@ -511,14 +511,14 @@ int hcl_ignite (hcl_t* hcl)
 	{
 		/* Create a nil process used to simplify nil check in GC.
 		 * only accessible by VM. not exported via the global dictionary. */
-		hcl->nil_process = (hcl_oop_process_t)hcl_allocoopobj (hcl, HCL_BRAND_PROCESS, HCL_PROCESS_NAMED_INSTVARS);
+		hcl->nil_process = (hcl_oop_process_t)hcl_allocoopobj(hcl, HCL_BRAND_PROCESS, HCL_PROCESS_NAMED_INSTVARS);
 		if (!hcl->nil_process) return -1;
 		hcl->nil_process->sp = HCL_SMOOI_TO_OOP(-1);
 	}
 
 	if (!hcl->processor)
 	{
-		hcl->processor = (hcl_oop_process_scheduler_t)hcl_allocoopobj (hcl, HCL_BRAND_PROCESS_SCHEDULER, HCL_PROCESS_SCHEDULER_NAMED_INSTVARS);
+		hcl->processor = (hcl_oop_process_scheduler_t)hcl_allocoopobj(hcl, HCL_BRAND_PROCESS_SCHEDULER, HCL_PROCESS_SCHEDULER_NAMED_INSTVARS);
 		if (!hcl->processor) return -1;
 		hcl->processor->tally = HCL_SMOOI_TO_OOP(0);
 		hcl->processor->active = hcl->nil_process;
@@ -526,14 +526,16 @@ int hcl_ignite (hcl_t* hcl)
 
 	if (!hcl->code.bc.arr)
 	{
-		hcl->code.bc.arr = (hcl_oop_byte_t)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, HCL_BC_BUFFER_INIT); /* TODO: set a proper intial size */
 		if (!hcl->code.bc.arr) return -1;
+		HCL_ASSERT (hcl, hcl->code.bc.len == 0);
 	}
 
 	if (!hcl->code.lit.arr)
 	{
-		hcl->code.lit.arr = (hcl_oop_oop_t)hcl_makengcarray (hcl, 20000); /* TOOD: set a proper initial size */
+		hcl->code.lit.arr = (hcl_oop_oop_t)hcl_makengcarray(hcl, HCL_LIT_BUFFER_INIT); /* TOOD: set a proper initial size */
 		if (!hcl->code.lit.arr) return -1;
+		HCL_ASSERT (hcl, hcl->code.lit.len == 0);
 	}
 
 	hcl->p.e = hcl->_nil;

lib/hcl-prv.h

@@ -75,6 +75,13 @@
  */
 #define HCL_LIMIT_OBJ_SIZE
 
+
+#define HCL_BC_BUFFER_INIT  10240
+#define HCL_BC_BUFFER_ALIGN 10240
+
+#define HCL_LIT_BUFFER_INIT 1024
+#define HCL_LIT_BUFFER_ALIGN 1024
+
 #if defined(__has_builtin)
 
 #	if (!__has_builtin(__builtin_memset) || !__has_builtin(__builtin_memcpy) || !__has_builtin(__builtin_memmove) || !__has_builtin(__builtin_memcmp))

lib/hcl.c

@@ -286,9 +286,26 @@ void hcl_fini (hcl_t* hcl)
 	}
 }
 
-void hcl_clear (hcl_t* hcl, int flags)
+void hcl_clear (hcl_t* hcl)
 {
-	/* TODO */
+	hcl_oop_t v;
+	hcl_oow_t i;
+
+#if 0
+	/* clear global variables -> especially lambdas, because they refer to the byte codes? */
+	for (i = 0; i < hcl->code.lit.len; i++)
+	{
+		v = ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[ip]);
+		if (HCL_IS_CONS(v))
+		{
+			hcl_delat
+		}
+	}
+#endif
+	/* clear the byte code and literals */
+	hcl->code.bc.len = 0;
+	hcl->code.lit.len = 0;
+	hcl_gc (hcl);
 }
 
 int hcl_setoption (hcl_t* hcl, hcl_option_t id, const void* value)

lib/hcl.h

@@ -1354,16 +1354,20 @@ HCL_EXPORT void hcl_close (
 );
 
 HCL_EXPORT int hcl_init (
-	hcl_t*              vm,
+	hcl_t*              hcl,
 	hcl_mmgr_t*         mmgr,
 	hcl_oow_t           heapsize,
 	const hcl_vmprim_t* vmprim
 );
 
 HCL_EXPORT void hcl_fini (
-	hcl_t* vm
+	hcl_t*              hcl
 );
 
+/*
+HCL_EXPORT void hcl_clear (
+	hcl_t*              hcl
+);*/
 
 #if defined(HCL_HAVE_INLINE)
 	static HCL_INLINE hcl_mmgr_t* hcl_getmmgr (hcl_t* hcl) { return hcl->mmgr; }