added hcl_walkdic

fixed a bug of not printing the list closer properly in hcl_print().
enhanced error handling

hcl/lib/dic.c

@@ -268,7 +268,7 @@ hcl_oop_t hcl_makedic (hcl_t* hcl, hcl_oow_t inisize)
 		obj->tally = HCL_SMOOI_TO_OOP(0);
 
 		hcl_pushtmp (hcl, (hcl_oop_t*)&obj);
-		bucket = (hcl_oop_oop_t)hcl_makearray (hcl, inisize);
+		bucket = (hcl_oop_oop_t)hcl_makearray(hcl, inisize);
 		hcl_poptmp (hcl);
 
 		if (!bucket) obj = HCL_NULL;
@@ -277,3 +277,20 @@ hcl_oop_t hcl_makedic (hcl_t* hcl, hcl_oow_t inisize)
 
 	return (hcl_oop_t)obj;
 }
+
+int hcl_walkdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_dic_walker_t walker, void* ctx)
+{
+	hcl_oow_t i;
+
+	hcl_pushtmp (hcl, (hcl_oop_t*)&dic);
+
+	for (i = 0; i < HCL_OBJ_GET_SIZE(dic->bucket); i++)
+	{
+		hcl_oop_t tmp = dic->bucket->slot[i];
+		if (HCL_IS_CONS(hcl, tmp) && walker(hcl, dic, (hcl_oop_cons_t)tmp, ctx) <= -1) return -1;
+	}
+
+	hcl_poptmp (hcl);
+	return 0;
+}
+

hcl/lib/err.c

@@ -59,13 +59,17 @@ static hcl_ooch_t errstr_29[] = {'d','i','v','i','d','e',' ','b','y',' ','z','e'
 static hcl_ooch_t errstr_30[] = {'I','/','O',' ','e','r','r','o','r','\0'};
 static hcl_ooch_t errstr_31[] = {'e','n','c','o','d','i','n','g',' ','c','o','n','v','e','r','s','i','o','n',' ','e','r','r','o','r','\0'};
 static hcl_ooch_t errstr_32[] = {'b','u','f','f','e','r',' ','f','u','l','l','\0'};
+static hcl_ooch_t errstr_33[] = {'s','y','n','t','a','x',' ','e','r','r','o','r','\0'};
+static hcl_ooch_t errstr_34[] = {'c','a','l','l',' ','e','r','r','o','r','\0'};
+static hcl_ooch_t errstr_35[] = {'r','e','c','a','l','l',' ','p','r','o','h','i','b','i','t','e','d','\0'};
+static hcl_ooch_t errstr_36[] = {'a','r','g','u','m','e','n','t',' ','n','u','m','b','e','r',' ','e','r','r','o','r','\0'};
 static hcl_ooch_t* errstr[] =
 {
 	errstr_0, errstr_1, errstr_2, errstr_3, errstr_4, errstr_5, errstr_6, errstr_7,
 	errstr_8, errstr_9, errstr_10, errstr_11, errstr_12, errstr_13, errstr_14, errstr_15,
 	errstr_16, errstr_17, errstr_18, errstr_19, errstr_20, errstr_21, errstr_22, errstr_23,
 	errstr_24, errstr_25, errstr_26, errstr_27, errstr_28, errstr_29, errstr_30, errstr_31,
-	errstr_32 
+	errstr_32, errstr_33, errstr_34, errstr_35, errstr_36
 };
 
 

hcl/lib/hcl-prv.h

@@ -888,33 +888,6 @@ hcl_oop_t hcl_findsymbol (
 );
 
 
-/* ========================================================================= */
-/* dic.c                                                                     */
-/* ========================================================================= */
-hcl_oop_cons_t hcl_putatsysdic (
-	hcl_t*     hcl,
-	hcl_oop_t  key,
-	hcl_oop_t  value
-);
-
-hcl_oop_cons_t hcl_getatsysdic (
-	hcl_t*     hcl,
-	hcl_oop_t  key
-);
-
-hcl_oop_cons_t hcl_putatdic (
-	hcl_t*        hcl,
-	hcl_oop_dic_t dic,
-	hcl_oop_t     key,
-	hcl_oop_t     value
-);
-
-hcl_oop_cons_t hcl_getatdic (
-	hcl_t*        hcl,
-	hcl_oop_dic_t dic,
-	hcl_oop_t     key
-);
-
 /* ========================================================================= */
 /* proc.c                                                                    */
 /* ========================================================================= */
@@ -1139,8 +1112,7 @@ HCL_EXPORT int hcl_compile (
 hcl_mod_data_t* hcl_openmod (
 	hcl_t*            hcl,
 	const hcl_ooch_t* name,
-	hcl_oow_t         namelen,
+	hcl_oow_t         namelen
-	int               hints /* 0 or bitwise-ORed of hcl_mod_hint_t enumerators */
 );
 
 void hcl_closemod (
@@ -1148,12 +1120,6 @@ void hcl_closemod (
 	hcl_mod_data_t*   mdp
 );
 
-int hcl_importmod (
-	hcl_t*            hcl,
-	const hcl_ooch_t* name,
-	hcl_oow_t         len
-);
-
 /*
  * The hcl_querymod() function finds a primitive function in modules
  * with a full primitive identifier.

hcl/lib/hcl.c

@@ -200,14 +200,14 @@ void hcl_fini (hcl_t* hcl)
 
 	if (hcl->code.bc.arr)
 	{
-		hcl_freengcobj (hcl, hcl->code.bc.arr);
+		hcl_freengcobj (hcl, (hcl_oop_t)hcl->code.bc.arr);
 		hcl->code.bc.arr = HCL_NULL;
 		hcl->code.bc.len = 0;
 	}
 
 	if (hcl->code.lit.arr)
 	{
-		hcl_freengcobj (hcl, hcl->code.lit.arr);
+		hcl_freengcobj (hcl, (hcl_oop_t)hcl->code.lit.arr);
 		hcl->code.lit.arr = HCL_NULL;
 		hcl->code.lit.len = 0;
 	}
@@ -396,19 +396,13 @@ void hcl_freemem (hcl_t* hcl, void* ptr)
 
 #if defined(HCL_ENABLE_STATIC_MODULE)
 
-#if defined(HCL_ENABLE_MOD_CON)
+/*#include "../mod/_array.h"*/
-#	include "../mod/_con.h"
+
-#endif
+static int hcl_mod_fake (hcl_t* hcl, hcl_mod_t* mod)
-#if defined(HCL_ENABLE_MOD_FFI)
+{
-#	include "../mod/_ffi.h"
+	hcl_seterrbfmt (hcl, HCL_EPERM, "not allowed to load ___fake___ module");
-#endif
+	return -1;
-#if defined(HCL_ENABLE_MOD_SCK)
+}
-#	include "../mod/_sck.h"
-#endif
-#include "../mod/_stdio.h"
-#if defined(HCL_ENABLE_MOD_X11)
-#	include "../mod/_x11.h"
-#endif
 
 static struct
 {
@@ -417,25 +411,11 @@ static struct
 }
 static_modtab[] = 
 {
-#if defined(HCL_ENABLE_MOD_CON)
+	{ "___fake___",      hcl_mod_fake },
-	{ "con",        hcl_mod_con },
-#endif
-#if defined(HCL_ENABLE_MOD_FFI)
-	{ "ffi",        hcl_mod_ffi },
-#endif
-#if defined(HCL_ENABLE_MOD_SCK)
-	{ "sck",        hcl_mod_sck },
-	{ "sck.addr",   hcl_mod_sck_addr },
-#endif
-	{ "stdio",      hcl_mod_stdio },
-#if defined(HCL_ENABLE_MOD_X11)
-	{ "x11",        hcl_mod_x11 },
-	/*{ "x11.win",    hcl_mod_x11_win },*/
-#endif
 };
 #endif
 
-hcl_mod_data_t* hcl_openmod (hcl_t* hcl, const hcl_ooch_t* name, hcl_oow_t namelen, int hints)
+hcl_mod_data_t* hcl_openmod (hcl_t* hcl, const hcl_ooch_t* name, hcl_oow_t namelen)
 {
 	hcl_rbt_pair_t* pair;
 	hcl_mod_data_t* mdp;
@@ -473,7 +453,7 @@ hcl_mod_data_t* hcl_openmod (hcl_t* hcl, const hcl_ooch_t* name, hcl_oow_t namel
 	/* TODO: binary search ... */
 	for (n = 0; n < HCL_COUNTOF(static_modtab); n++)
 	{
-		if (hcl_compoocharsbcstr (name, namelen, static_modtab[n].modname) == 0) 
+		if (hcl_compoocharsbcstr(name, namelen, static_modtab[n].modname) == 0) 
 		{
 			load = static_modtab[n].modload;
 			break;
@@ -490,7 +470,7 @@ hcl_mod_data_t* hcl_openmod (hcl_t* hcl, const hcl_ooch_t* name, hcl_oow_t namel
 
 		/* i copy-insert 'md' into the table before calling 'load'.
 		 * to pass the same address to load(), query(), etc */
-		pair = hcl_rbt_insert (&hcl->modtab, (hcl_ooch_t*)name, namelen, &md, HCL_SIZEOF(md));
+		pair = hcl_rbt_insert(&hcl->modtab, (hcl_ooch_t*)name, namelen, &md, HCL_SIZEOF(md));
 		if (pair == HCL_NULL)
 		{
 			hcl_seterrnum (hcl, HCL_ESYSMEM);
@@ -499,8 +479,7 @@ hcl_mod_data_t* hcl_openmod (hcl_t* hcl, const hcl_ooch_t* name, hcl_oow_t namel
 
 		mdp = (hcl_mod_data_t*)HCL_RBT_VPTR(pair);
 		HCL_ASSERT (hcl, HCL_SIZEOF(mdp->mod.hints) == HCL_SIZEOF(int));
-		mdp->mod.hints = hints;
+		if (load(hcl, &mdp->mod) <= -1)
-		if (load (hcl, &mdp->mod) <= -1)
 		{
 			hcl_rbt_delete (&hcl->modtab, (hcl_ooch_t*)name, namelen);
 			return HCL_NULL;
@@ -529,10 +508,10 @@ hcl_mod_data_t* hcl_openmod (hcl_t* hcl, const hcl_ooch_t* name, hcl_oow_t namel
 
 	/* attempt to find a dynamic external module */
 	HCL_MEMSET (&md, 0, HCL_SIZEOF(md));
-	hcl_copyoochars ((hcl_ooch_t*)md.mod.name, name, namelen);
+	hcl_copyoochars((hcl_ooch_t*)md.mod.name, name, namelen);
 	if (hcl->vmprim.dl_open && hcl->vmprim.dl_getsym && hcl->vmprim.dl_close)
 	{
-		md.handle = hcl->vmprim.dl_open (hcl, &buf[MOD_PREFIX_LEN], HCL_VMPRIM_OPENDL_PFMOD);
+		md.handle = hcl->vmprim.dl_open(hcl, &buf[MOD_PREFIX_LEN], HCL_VMPRIM_OPENDL_PFMOD);
 	}
 
 	if (md.handle == HCL_NULL) 
@@ -543,11 +522,10 @@ hcl_mod_data_t* hcl_openmod (hcl_t* hcl, const hcl_ooch_t* name, hcl_oow_t namel
 	}
 
 	/* attempt to get hcl_mod_xxx where xxx is the module name*/
-	load = hcl->vmprim.dl_getsym (hcl, md.handle, buf);
+	load = hcl->vmprim.dl_getsym(hcl, md.handle, buf);
 	if (!load) 
 	{
-		const hcl_ooch_t* oldmsg = hcl_backuperrmsg (hcl);
+		hcl_seterrbfmt (hcl, hcl_geterrnum(hcl), "unable to get module symbol [%js] in [%.*js]", buf, namelen, name);
-		hcl_seterrbfmt (hcl, hcl_geterrnum(hcl), "unable to get module symbol [%js] in [%.*js] - %js", buf, namelen, name, oldmsg);
 		HCL_DEBUG3 (hcl, "Cannot get a module symbol [%js] in [%.*js]\n", buf, namelen, name);
 		hcl->vmprim.dl_close (hcl, md.handle);
 		return HCL_NULL;
@@ -555,7 +533,7 @@ hcl_mod_data_t* hcl_openmod (hcl_t* hcl, const hcl_ooch_t* name, hcl_oow_t namel
 
 	/* i copy-insert 'md' into the table before calling 'load'.
 	 * to pass the same address to load(), query(), etc */
-	pair = hcl_rbt_insert (&hcl->modtab, (void*)name, namelen, &md, HCL_SIZEOF(md));
+	pair = hcl_rbt_insert(&hcl->modtab, (void*)name, namelen, &md, HCL_SIZEOF(md));
 	if (pair == HCL_NULL)
 	{
 		HCL_DEBUG2 (hcl, "Cannot register a module [%.*js]\n", namelen, name);
@@ -566,8 +544,7 @@ hcl_mod_data_t* hcl_openmod (hcl_t* hcl, const hcl_ooch_t* name, hcl_oow_t namel
 
 	mdp = (hcl_mod_data_t*)HCL_RBT_VPTR(pair);
 	HCL_ASSERT (hcl, HCL_SIZEOF(mdp->mod.hints) == HCL_SIZEOF(int));
-	mdp->mod.hints = hints;
+	if (load(hcl, &mdp->mod) <= -1)
-	if (load (hcl, &mdp->mod) <= -1)
 	{
 		const hcl_ooch_t* oldmsg = hcl_backuperrmsg (hcl);
 		hcl_seterrbfmt (hcl, hcl_geterrnum(hcl), "module initializer [%js] returned failure in [%.*js] - %js", buf, namelen, name, oldmsg); 
@@ -609,53 +586,6 @@ void hcl_closemod (hcl_t* hcl, hcl_mod_data_t* mdp)
 	}
 }
 
-int hcl_importmod (hcl_t* hcl, const hcl_ooch_t* name, hcl_oow_t len)
-{
-	hcl_rbt_pair_t* pair;
-	hcl_mod_data_t* mdp;
-	int r = -1;
-
-	pair = hcl_rbt_search (&hcl->modtab, name, len);
-	if (pair)
-	{
-		mdp = (hcl_mod_data_t*)HCL_RBT_VPTR(pair);
-		HCL_ASSERT (hcl, mdp != HCL_NULL);
-
-		HCL_DEBUG1 (hcl, "Cannot import module [%js] - already active\n", mdp->mod.name);
-		hcl_seterrbfmt (hcl, HCL_EPERM, "unable to import module [%js] - already active", mdp->mod.name);
-		goto done2;
-	}
-
-	mdp = hcl_openmod (hcl, name, len, HCL_MOD_LOAD_FOR_IMPORT);
-	if (!mdp) goto done2;
-
-	if (!mdp->mod.import)
-	{
-		HCL_DEBUG1 (hcl, "Cannot import module [%js] - importing not supported by the module\n", mdp->mod.name);
-		hcl_seterrbfmt (hcl, HCL_ENOIMPL, "unable to import module [%js] - not supported by the module", mdp->mod.name);
-		goto done;
-	}
-
-	if (mdp->mod.import (hcl, &mdp->mod) <= -1)
-	{
-		HCL_DEBUG1 (hcl, "Cannot import module [%js] - module's import() returned failure\n", mdp->mod.name);
-		goto done;
-	}
-
-	r = 0; /* everything successful */
-
-done:
-	/* close the module opened above.
-	 * [NOTE] if the import callback calls the hcl_querymod(), the returned
-	 *        function pointers will get all invalidated here. so never do 
-	 *        anything like that */
-	hcl_closemod (hcl, mdp);
-
-done2:
-	return r;
-
-}
-
 hcl_pfbase_t* hcl_querymod (hcl_t* hcl, const hcl_ooch_t* pfid, hcl_oow_t pfidlen)
 {
 	/* primitive function identifier
@@ -696,7 +626,7 @@ hcl_pfbase_t* hcl_querymod (hcl_t* hcl, const hcl_ooch_t* pfid, hcl_oow_t pfidle
 	else
 	{
 		/* open a module using the part before the last period */
-		mdp = hcl_openmod (hcl, pfid, mod_name_len, 0);
+		mdp = hcl_openmod (hcl, pfid, mod_name_len);
 		if (!mdp) return HCL_NULL;
 	}
 
@@ -713,3 +643,40 @@ hcl_pfbase_t* hcl_querymod (hcl_t* hcl, const hcl_ooch_t* pfid, hcl_oow_t pfidle
 	return pfbase;
 }
 
+
+hcl_pfbase_t* hcl_findpfbase (hcl_t* hcl, hcl_pfinfo_t* pfinfo, hcl_oow_t pfcount, const hcl_ooch_t* name, hcl_oow_t namelen)
+{
+	int n;
+
+	/* binary search */
+#if 0
+	/* [NOTE] this algorithm is NOT underflow safe with hcl_oow_t types */
+	int left, right, mid;
+
+	for (left = 0, right = pfcount - 1; left <= right; )
+	{
+		/*mid = (left + right) / 2;*/
+		mid = left + ((right - left) / 2);
+
+		n = hcl_compoocharsoocstr (name, namelen, pfinfo[mid].mthname);
+		if (n < 0) right = mid - 1; /* this substraction can make right negative. so i can't use hcl_oow_t for the variable */
+		else if (n > 0) left = mid + 1;
+		else return &pfinfo[mid].base;
+	}
+#else
+	/* [NOTE] this algorithm is underflow safe with hcl_oow_t types */
+	hcl_oow_t base, mid, lim;
+
+	for (base = 0, lim = pfcount; lim > 0; lim >>= 1)
+	{
+		mid = base + (lim >> 1);
+		n = hcl_compoocharsoocstr (name, namelen, pfinfo[mid].mthname);
+		if (n == 0) return &pfinfo[mid].base;
+		if (n > 0) { base = mid + 1; lim--; }
+	}
+#endif
+
+	hcl_seterrnum (hcl, HCL_ENOENT);
+	return HCL_NULL;
+}
+

hcl/lib/main.c

@@ -504,8 +504,11 @@ static void* dl_open (hcl_t* hcl, const hcl_ooch_t* name, int flags)
 			if (!handle) 
 			{
 				hcl_bch_t* dash;
-				hcl_seterrbfmt (hcl, HCL_ESYSERR, "unable to open(ext) DL %js - %hs", name, sys_dl_error());
+				const hcl_bch_t* dl_errstr;
-				HCL_DEBUG3 (hcl, "Failed to open(ext) DL %hs[%js] - %hs\n", &bufptr[len], name, sys_dl_error());
+				dl_errstr = sys_dl_error();
+				HCL_DEBUG3 (hcl, "Failed to open(ext) DL %hs[%js] - %hs\n", &bufptr[len], name, dl_errstr);
+				hcl_seterrbfmt (hcl, HCL_ESYSERR, "unable to open(ext) DL %js - %hs", name, dl_errstr);
+
 				dash = hcl_rfindbchar(bufptr, hcl_countbcstr(bufptr), '-');
 				if (dash) 
 				{
@@ -537,13 +540,15 @@ static void* dl_open (hcl_t* hcl, const hcl_ooch_t* name, int flags)
 		bcslen = hcl_copybcstr(bufptr, bufcapa, name);
 	#endif
 
-		if (hcl_findbchar (bufptr, bcslen, '.'))
+		if (hcl_findbchar(bufptr, bcslen, '.'))
 		{
 			handle = sys_dl_open(bufptr);
 			if (!handle) 
 			{
-				hcl_seterrbfmt (hcl, HCL_ESYSERR, "unable to open DL %js - %hs", name, sys_dl_error());
+				const hcl_bch_t* dl_errstr;
-				HCL_DEBUG2 (hcl, "Failed to open DL %hs - %hs\n", bufptr, sys_dl_error());
+				dl_errstr = sys_dl_error();
+				HCL_DEBUG2 (hcl, "Failed to open DL %hs - %hs\n", bufptr, dl_errstr);
+				hcl_seterrbfmt (hcl, HCL_ESYSERR, "unable to open DL %js - %hs", name, dl_errstr);
 			}
 			else HCL_DEBUG2 (hcl, "Opened DL %hs handle %p\n", bufptr, handle);
 		}
@@ -552,8 +557,10 @@ static void* dl_open (hcl_t* hcl, const hcl_ooch_t* name, int flags)
 			handle = sys_dl_openext(bufptr);
 			if (!handle) 
 			{
-				hcl_seterrbfmt (hcl, HCL_ESYSERR, "unable to open(ext) DL %js - %hs", name, sys_dl_error());
+				const hcl_bch_t* dl_errstr;
-				HCL_DEBUG2 (hcl, "Failed to open(ext) DL %hs - %s\n", bufptr, sys_dl_error());
+				dl_errstr = sys_dl_error();
+				HCL_DEBUG2 (hcl, "Failed to open(ext) DL %hs - %s\n", bufptr, dl_errstr);
+				hcl_seterrbfmt (hcl, HCL_ESYSERR, "unable to open(ext) DL %js - %hs", name, dl_errstr);
 			}
 			else HCL_DEBUG2 (hcl, "Opened(ext) DL %hs handle %p\n", bufptr, handle);
 		}
@@ -642,7 +649,11 @@ static void* dl_getsym (hcl_t* hcl, void* handle, const hcl_ooch_t* name)
 				sym = sys_dl_getsym(handle, symname);
 				if (!sym)
 				{
-					hcl_seterrbfmt (hcl, HCL_ENOENT, "unable to get module symbol %hs", symname);
+					const hcl_bch_t* dl_errstr;
+					dl_errstr = sys_dl_error();
+					HCL_DEBUG3 (hcl, "Failed to get module symbol %js from handle %p - %hs\n", name, handle, dl_errstr);
+					hcl_seterrbfmt (hcl, HCL_ENOENT, "unable to get module symbol %hs - %hs", symname, dl_errstr);
+					
 				}
 			}
 		}

hcl/lib/prim.c

@@ -487,3 +487,59 @@ int hcl_addbuiltinprims (hcl_t* hcl)
 
 	return 0;
 }
+
+
+/* ------------------------------------------------------------------------- */
+
+
+static hcl_pfrc_t pf_hello (hcl_t* hcl, hcl_ooi_t nargs)
+{
+	return prim_log(hcl, nargs);
+}
+
+static int walker (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_cons_t pair, void* ctx)
+{
+	HCL_DEBUG2 (hcl, "walker ===> %O  =====> %O\n", HCL_CONS_CAR(pair), HCL_CONS_CDR(pair));
+	return 0;
+}
+
+static hcl_pfrc_t pf_walk (hcl_t* hcl, hcl_ooi_t nargs)
+{
+	hcl_oop_t arg;
+
+	arg = HCL_STACK_GETARG(hcl, nargs, 0);
+	if (!HCL_IS_DIC(hcl,arg))
+	{
+		hcl_seterrbfmt (hcl, HCL_EINVAL, "parameter not a dictionary - %O", arg);
+		return HCL_PF_FAILURE;
+	}
+
+	hcl_walkdic (hcl, (hcl_oop_dic_t)arg, walker, HCL_NULL);
+	HCL_STACK_SETRET (hcl, nargs, hcl->_true);
+	return HCL_PF_SUCCESS;
+}
+
+static hcl_pfinfo_t pfinfos[] =
+{
+	{ { 'h','e','l','l','o','\0' },         0, { pf_hello,  1,  1  } },
+	{ { 'w','a','l','k','\0' },             0, { pf_walk,   1,  1  } }
+};
+
+/* ------------------------------------------------------------------------ */
+
+static hcl_pfbase_t* query (hcl_t* hcl, hcl_mod_t* mod, const hcl_ooch_t* name, hcl_oow_t namelen)
+{
+	return hcl_findpfbase (hcl, pfinfos, HCL_COUNTOF(pfinfos), name, namelen);
+}
+
+static void unload (hcl_t* hcl, hcl_mod_t* mod)
+{
+}
+
+int hcl_mod_test (hcl_t* hcl, hcl_mod_t* mod)
+{
+	mod->query = query;
+	mod->unload = unload; 
+	mod->ctx = HCL_NULL;
+	return 0;
+}

hcl/lib/print.c

@@ -296,6 +296,7 @@ next:
 				 * the variable p is */
 				ps.type = PRINT_STACK_CONS;
 				ps.obj = HCL_CONS_CDR(cur);
+				ps.idx = concode; /* this is not an index but use this field to restore concode */
 				x = push (hcl, &ps);
 				if (x <= -1) return -1;
 
@@ -309,6 +310,7 @@ next:
 			resume_cons:
 				HCL_ASSERT (hcl, ps.type == PRINT_STACK_CONS);
 				cur = ps.obj; /* Get back the CDR pushed */
+				concode = ps.idx; /* restore the concode */
 				if (HCL_IS_NIL(hcl,cur)) 
 				{
 					/* The CDR part points to a NIL object, which