renamed hcl_purgeatdic() to hcl_zapatdic()
exposed hcl_moveoop() extended the meaning of the kernel bits in the object flags extended hcl_pfbase_t to include the type - one of HCL_PFBASE_FUNC, HCL_PFBASE_VAR, HCL_PFBASE_CONST. HCL_PFBASE_CONST not fully implemented yet
This commit is contained in:
parent
02b02865ac
commit
a60bd0c898
@ -868,7 +868,7 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src, int defun)
|
||||
return -1;
|
||||
}
|
||||
|
||||
if (HCL_OBJ_GET_FLAGS_SYNCODE(defun_name) || HCL_OBJ_GET_FLAGS_KERNEL(defun_name))
|
||||
if (HCL_OBJ_GET_FLAGS_SYNCODE(defun_name) || HCL_OBJ_GET_FLAGS_KERNEL(defun_name) >= 1)
|
||||
{
|
||||
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_NULL, HCL_NULL,
|
||||
"special symbol not to be used as a defun name - %O", defun_name); /* TOOD: error location */
|
||||
@ -925,7 +925,7 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src, int defun)
|
||||
return -1;
|
||||
}
|
||||
|
||||
if (HCL_OBJ_GET_FLAGS_SYNCODE(arg) || HCL_OBJ_GET_FLAGS_KERNEL(arg))
|
||||
if (HCL_OBJ_GET_FLAGS_SYNCODE(arg) || HCL_OBJ_GET_FLAGS_KERNEL(arg) >= 2)
|
||||
{
|
||||
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDARGNAME, HCL_NULL, HCL_NULL,
|
||||
"special symbol not to be declared as an argument - %O", arg); /* TOOD: error location */
|
||||
@ -986,7 +986,7 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src, int defun)
|
||||
for (i = 0; i < sz; i++)
|
||||
{
|
||||
if (HCL_OBJ_GET_FLAGS_SYNCODE(((hcl_oop_oop_t)dcl)->slot[i]) ||
|
||||
HCL_OBJ_GET_FLAGS_KERNEL(((hcl_oop_oop_t)dcl)->slot[i]))
|
||||
HCL_OBJ_GET_FLAGS_KERNEL(((hcl_oop_oop_t)dcl)->slot[i]) >= 2)
|
||||
{
|
||||
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_NULL, HCL_NULL,
|
||||
"special symbol not to be declared as a variable - %O", obj); /* TOOD: error location */
|
||||
@ -1135,7 +1135,7 @@ static int compile_set (hcl_t* hcl, hcl_oop_t src)
|
||||
return -1;
|
||||
}
|
||||
|
||||
if (HCL_OBJ_GET_FLAGS_SYNCODE(var) || HCL_OBJ_GET_FLAGS_KERNEL(var))
|
||||
if (HCL_OBJ_GET_FLAGS_SYNCODE(var) || HCL_OBJ_GET_FLAGS_KERNEL(var) >= 2)
|
||||
{
|
||||
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_NULL, HCL_NULL, "special symbol not to be used as a variable name - %O", var); /* TOOD: error location */
|
||||
return -1;
|
||||
|
42
lib/dic.c
42
lib/dic.c
@ -92,7 +92,11 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc)
|
||||
return newbuc;
|
||||
}
|
||||
|
||||
#if defined(SYMBOL_ONLY_KEY)
|
||||
static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_char_t key, hcl_oop_t value)
|
||||
#else
|
||||
static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key, hcl_oop_t value)
|
||||
#endif
|
||||
{
|
||||
hcl_ooi_t tally;
|
||||
hcl_oow_t index;
|
||||
@ -110,7 +114,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_cha
|
||||
#if defined(SYMBOL_ONLY_KEY)
|
||||
index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket);
|
||||
#else
|
||||
if (hcl_hashobj(hcl, (hcl_oop_t)key, &index) <= -1) return HCL_NULL;
|
||||
if (hcl_hashobj(hcl, key, &index) <= -1) return HCL_NULL;
|
||||
index %= HCL_OBJ_GET_SIZE(dic->bucket);
|
||||
#endif
|
||||
|
||||
@ -135,7 +139,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_cha
|
||||
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);
|
||||
n = hcl_equalobjs(hcl, key, ass->car);
|
||||
if (n <= -1) return HCL_NULL;
|
||||
if (n >= 1)
|
||||
{
|
||||
@ -196,7 +200,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_cha
|
||||
/* recalculate the index for the expanded bucket */
|
||||
index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket);
|
||||
#else
|
||||
hcl_hashobj(hcl, (hcl_oop_t)key, &index); /* this must succeed as i know 'key' is hashable */
|
||||
hcl_hashobj(hcl, key, &index); /* this must succeed as i know 'key' is hashable */
|
||||
index %= HCL_OBJ_GET_SIZE(dic->bucket);
|
||||
#endif
|
||||
|
||||
@ -206,7 +210,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_cha
|
||||
|
||||
/* create a new assocation of a key and a value since
|
||||
* the key isn't found in the root dictionary */
|
||||
ass = (hcl_oop_cons_t)hcl_makecons (hcl, (hcl_oop_t)key, (hcl_oop_t)value);
|
||||
ass = (hcl_oop_cons_t)hcl_makecons (hcl, (hcl_oop_t)key, value);
|
||||
if (!ass) goto oops;
|
||||
|
||||
/* the current tally must be less than the maximum value. otherwise,
|
||||
@ -228,7 +232,7 @@ hcl_oop_cons_t hcl_putatsysdic (hcl_t* hcl, hcl_oop_t key, hcl_oop_t value)
|
||||
#if defined(SYMBOL_ONLY_KEY)
|
||||
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
|
||||
#endif
|
||||
return find_or_upsert (hcl, hcl->sysdic, (hcl_oop_char_t)key, value);
|
||||
return find_or_upsert(hcl, hcl->sysdic, key, value);
|
||||
}
|
||||
|
||||
hcl_oop_cons_t hcl_getatsysdic (hcl_t* hcl, hcl_oop_t key)
|
||||
@ -236,7 +240,15 @@ hcl_oop_cons_t hcl_getatsysdic (hcl_t* hcl, hcl_oop_t key)
|
||||
#if defined(SYMBOL_ONLY_KEY)
|
||||
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
|
||||
#endif
|
||||
return find_or_upsert (hcl, hcl->sysdic, (hcl_oop_char_t)key, HCL_NULL);
|
||||
return find_or_upsert(hcl, hcl->sysdic, key, HCL_NULL);
|
||||
}
|
||||
|
||||
int hcl_zapatsysdic (hcl_t* hcl, hcl_oop_t key)
|
||||
{
|
||||
#if defined(SYMBOL_ONLY_KEY)
|
||||
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
|
||||
#endif
|
||||
return hcl_zapatdic(hcl, hcl->sysdic, key);
|
||||
}
|
||||
|
||||
hcl_oop_cons_t hcl_putatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key, hcl_oop_t value)
|
||||
@ -244,7 +256,7 @@ hcl_oop_cons_t hcl_putatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key, hcl_o
|
||||
#if defined(SYMBOL_ONLY_KEY)
|
||||
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
|
||||
#endif
|
||||
return find_or_upsert (hcl, dic, (hcl_oop_char_t)key, value);
|
||||
return find_or_upsert(hcl, dic, key, value);
|
||||
}
|
||||
|
||||
hcl_oop_cons_t hcl_getatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key)
|
||||
@ -252,13 +264,13 @@ hcl_oop_cons_t hcl_getatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key)
|
||||
#if defined(SYMBOL_ONLY_KEY)
|
||||
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
|
||||
#endif
|
||||
return find_or_upsert (hcl, dic, (hcl_oop_char_t)key, HCL_NULL);
|
||||
return find_or_upsert(hcl, dic, key, HCL_NULL);
|
||||
}
|
||||
|
||||
int hcl_purgeatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key)
|
||||
int hcl_zapatdic (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_oow_t index, bs, i, x, y, z;
|
||||
hcl_oop_cons_t ass;
|
||||
|
||||
tally = HCL_OOP_TO_SMOOI(dic->tally);
|
||||
@ -275,7 +287,7 @@ int hcl_purgeatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key)
|
||||
#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;
|
||||
if (hcl_hashobj(hcl, key, &index) <= -1) return -1;
|
||||
index %= bs;
|
||||
#endif
|
||||
|
||||
@ -288,7 +300,7 @@ int hcl_purgeatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key)
|
||||
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(HCL_OBJ_GET_CHAR_SLOT(key), HCL_OBJ_GET_CHAR_SLOT(ass->car), HCL_OBJ_GET_SIZE(key)))
|
||||
{
|
||||
/* the value of HCL_NULL indicates no insertion or update. */
|
||||
goto found;
|
||||
@ -304,7 +316,7 @@ int hcl_purgeatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key)
|
||||
if (n >= 1) goto found;
|
||||
#endif
|
||||
|
||||
index = (index + 1) % HCL_OBJ_GET_SIZE(dic->bucket);
|
||||
index = (index + 1) % bs;
|
||||
}
|
||||
|
||||
hcl_seterrnum (hcl, HCL_ENOENT);
|
||||
@ -323,10 +335,10 @@ found:
|
||||
#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;
|
||||
z = hcl_hashoochars(HCL_OBJ_GET_CHAR_SLOT(ass->car), HCL_OBJ_GET_SIZE(ass->car)) % bs;
|
||||
#else
|
||||
if (hcl_hashobj(hcl, ass->car, &z) <= -1) return -1;
|
||||
index %= bs;
|
||||
z %= bs;
|
||||
#endif
|
||||
|
||||
/* move an element if necesary */
|
||||
|
@ -1165,12 +1165,12 @@ static int execute (hcl_t* hcl)
|
||||
}*/
|
||||
|
||||
/* TODO: implement different process switching scheme - time-slice or clock based??? */
|
||||
#if defined(HCL_EXTERNAL_PROCESS_SWITCH)
|
||||
#if defined(HCL_EXTERNAL_PROCESS_SWITCH)
|
||||
if (!hcl->proc_switched && hcl->switch_proc) { switch_to_next_runnable_process (hcl); }
|
||||
hcl->switch_proc = 0;
|
||||
#else
|
||||
#else
|
||||
if (!hcl->proc_switched) { switch_to_next_runnable_process (hcl); }
|
||||
#endif
|
||||
#endif
|
||||
|
||||
hcl->proc_switched = 0;
|
||||
|
||||
|
1
lib/gc.c
1
lib/gc.c
@ -539,5 +539,6 @@ int hcl_ignite (hcl_t* hcl)
|
||||
}
|
||||
|
||||
hcl->p.e = hcl->_nil;
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
@ -718,15 +718,6 @@ void* hcl_allocheapmem (
|
||||
hcl_oow_t size
|
||||
);
|
||||
|
||||
|
||||
/* ========================================================================= */
|
||||
/* gc.c */
|
||||
/* ========================================================================= */
|
||||
hcl_oop_t hcl_moveoop (
|
||||
hcl_t* hcl,
|
||||
hcl_oop_t oop
|
||||
);
|
||||
|
||||
/* ========================================================================= */
|
||||
/* obj.c */
|
||||
/* ========================================================================= */
|
||||
|
20
lib/hcl.c
20
lib/hcl.c
@ -286,25 +286,29 @@ void hcl_fini (hcl_t* hcl)
|
||||
}
|
||||
}
|
||||
|
||||
void hcl_clear (hcl_t* hcl)
|
||||
void hcl_reset (hcl_t* hcl)
|
||||
{
|
||||
hcl_oop_t v;
|
||||
hcl_oow_t i;
|
||||
|
||||
#if 0
|
||||
/* clear global variables -> especially lambdas, because they refer to the byte codes? */
|
||||
/* delete all literals shown in the literal frame from the system dictionary
|
||||
* excluding special kernel symbols. */
|
||||
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))
|
||||
v = ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[i];
|
||||
if (HCL_IS_CONS(hcl, v))
|
||||
{
|
||||
hcl_delat
|
||||
hcl_oop_t key = HCL_CONS_CAR(v);
|
||||
if (!HCL_IS_SYMBOL(hcl,key) || !HCL_OBJ_GET_FLAGS_KERNEL(key))
|
||||
hcl_zapatsysdic (hcl, HCL_CONS_CAR(v));
|
||||
}
|
||||
}
|
||||
#endif
|
||||
/* clear the byte code and literals */
|
||||
|
||||
/* zap the byte code buffer and the literal frame */
|
||||
hcl->code.bc.len = 0;
|
||||
hcl->code.lit.len = 0;
|
||||
|
||||
/* clean up object memory */
|
||||
hcl_gc (hcl);
|
||||
}
|
||||
|
||||
|
64
lib/hcl.h
64
lib/hcl.h
@ -375,9 +375,11 @@ typedef enum hcl_obj_type_t hcl_obj_type_t;
|
||||
* item than the value of the size field. used for a
|
||||
* terminating null in a variable-char object. internel
|
||||
* use only.
|
||||
* kernel: 0 or 1. indicates that the object is a kernel object.
|
||||
* VM disallows layout changes of a kernel object.
|
||||
* internal use only.
|
||||
* kernel: 0 - ordinary object.
|
||||
* 1 - kernel object. can survive hcl_reset().
|
||||
* 2 - kernel object. can survive hcl_reset().
|
||||
* a symbol object with 2 in the kernel bits cannot be assigned a
|
||||
* value with the 'set' special form.
|
||||
* moved: 0 or 1. used by GC. internal use only.
|
||||
* ngc: 0 or 1, used by GC. internal use only.
|
||||
* trailer: 0 or 1. indicates that there are trailing bytes
|
||||
@ -857,22 +859,30 @@ typedef enum hcl_pfrc_t hcl_pfrc_t;
|
||||
typedef hcl_pfrc_t (*hcl_pfimpl_t) (
|
||||
hcl_t* hcl,
|
||||
hcl_mod_t* mod,
|
||||
hcl_ooi_t nargs);
|
||||
hcl_ooi_t nargs
|
||||
);
|
||||
|
||||
enum hcl_pfbase_type_t
|
||||
{
|
||||
HCL_PFBASE_FUNC = 0,
|
||||
HCL_PFBASE_VAR = 1,
|
||||
HCL_PFBASE_CONST = 2
|
||||
};
|
||||
typedef enum hcl_pfbase_type_t hcl_pfbase_type_t;
|
||||
|
||||
typedef struct hcl_pfbase_t hcl_pfbase_t;
|
||||
struct hcl_pfbase_t
|
||||
{
|
||||
hcl_pfimpl_t handler;
|
||||
hcl_oow_t minargs;
|
||||
hcl_oow_t maxargs;
|
||||
hcl_pfbase_type_t type;
|
||||
hcl_pfimpl_t handler;
|
||||
hcl_oow_t minargs;
|
||||
hcl_oow_t maxargs;
|
||||
};
|
||||
|
||||
typedef struct hcl_pfinfo_t hcl_pfinfo_t;
|
||||
struct hcl_pfinfo_t
|
||||
{
|
||||
hcl_ooch_t mthname[32];
|
||||
int variadic;
|
||||
hcl_pfbase_t base;
|
||||
};
|
||||
/* =========================================================================
|
||||
@ -1364,10 +1374,17 @@ HCL_EXPORT void hcl_fini (
|
||||
hcl_t* hcl
|
||||
);
|
||||
|
||||
/*
|
||||
HCL_EXPORT void hcl_clear (
|
||||
/**
|
||||
* The hcl_reset() function some internal states back to the initial state.
|
||||
* The affected internal states include byte code buffer, literal frame,
|
||||
* ordinary global variables. You should take extra precaution as it is
|
||||
* a risky function. For instance, a global variable inserted manually
|
||||
* with hcl_putatsysdic() gets deleted if the kernel bit is not set on
|
||||
* the variable symbol.
|
||||
*/
|
||||
HCL_EXPORT void hcl_reset (
|
||||
hcl_t* hcl
|
||||
);*/
|
||||
);
|
||||
|
||||
#if defined(HCL_HAVE_INLINE)
|
||||
static HCL_INLINE hcl_mmgr_t* hcl_getmmgr (hcl_t* hcl) { return hcl->mmgr; }
|
||||
@ -1467,6 +1484,19 @@ HCL_EXPORT void hcl_gc (
|
||||
hcl_t* hcl
|
||||
);
|
||||
|
||||
|
||||
/**
|
||||
* The hcl_moveoop() function is used to move a live object to a new
|
||||
* location in hcl_gc(). When hcl_gc() invokes registered gc callbacks,
|
||||
* you may call this function to protect extra objects you might have
|
||||
* allocated manually.
|
||||
*/
|
||||
hcl_oop_t hcl_moveoop (
|
||||
hcl_t* hcl,
|
||||
hcl_oop_t oop
|
||||
);
|
||||
|
||||
|
||||
HCL_EXPORT hcl_oow_t hcl_getpayloadbytes (
|
||||
hcl_t* hcl,
|
||||
hcl_oop_t oop
|
||||
@ -1814,6 +1844,11 @@ HCL_EXPORT hcl_oop_cons_t hcl_getatsysdic (
|
||||
hcl_oop_t key
|
||||
);
|
||||
|
||||
HCL_EXPORT int hcl_zapatsysdic (
|
||||
hcl_t* hcl,
|
||||
hcl_oop_t key
|
||||
);
|
||||
|
||||
HCL_EXPORT hcl_oop_cons_t hcl_putatdic (
|
||||
hcl_t* hcl,
|
||||
hcl_oop_dic_t dic,
|
||||
@ -1827,6 +1862,13 @@ HCL_EXPORT hcl_oop_cons_t hcl_getatdic (
|
||||
hcl_oop_t key
|
||||
);
|
||||
|
||||
|
||||
HCL_EXPORT int hcl_zapatdic (
|
||||
hcl_t* hcl,
|
||||
hcl_oop_dic_t dic,
|
||||
hcl_oop_t key
|
||||
);
|
||||
|
||||
HCL_EXPORT int hcl_walkdic (
|
||||
hcl_t* hcl,
|
||||
hcl_oop_dic_t dic,
|
||||
|
40
lib/main.c
40
lib/main.c
@ -146,6 +146,8 @@ struct xtn_t
|
||||
int logfd_istty;
|
||||
|
||||
int reader_istty;
|
||||
|
||||
hcl_oop_t sym_errstr;
|
||||
};
|
||||
|
||||
/* ========================================================================= */
|
||||
@ -1216,6 +1218,12 @@ static void vm_sleep (hcl_t* hcl, const hcl_ntime_t* dur)
|
||||
|
||||
/* ========================================================================= */
|
||||
|
||||
static void gc_hcl (hcl_t* hcl)
|
||||
{
|
||||
xtn_t* xtn = (xtn_t*)hcl_getxtn(hcl);
|
||||
if (xtn->sym_errstr) xtn->sym_errstr = hcl_moveoop(hcl, xtn->sym_errstr);
|
||||
}
|
||||
|
||||
static void fini_hcl (hcl_t* hcl)
|
||||
{
|
||||
xtn_t* xtn = (xtn_t*)hcl_getxtn(hcl);
|
||||
@ -1629,6 +1637,7 @@ int main (int argc, char* argv[])
|
||||
|
||||
memset (&hclcb, 0, HCL_SIZEOF(hclcb));
|
||||
hclcb.fini = fini_hcl;
|
||||
hclcb.gc = gc_hcl;
|
||||
hcl_regcb (hcl, &hclcb);
|
||||
|
||||
|
||||
@ -1676,14 +1685,31 @@ int main (int argc, char* argv[])
|
||||
|
||||
if (hcl_attachio(hcl, read_handler, print_handler) <= -1)
|
||||
{
|
||||
hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot attache input stream - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl));
|
||||
hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot attach input stream - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl));
|
||||
hcl_close (hcl);
|
||||
return -1;
|
||||
}
|
||||
|
||||
{
|
||||
hcl_ooch_t errstr[] = { 'E', 'R', 'R', 'S', 'T', 'R' };
|
||||
xtn->sym_errstr = hcl_makesymbol(hcl, errstr, 6);
|
||||
if (!xtn->sym_errstr)
|
||||
{
|
||||
hcl_logbfmt (hcl, HCL_LOG_STDERR, "ERROR: cannot create the ERRSTR symbol - [%d] %js\n", hcl_geterrnum(hcl), hcl_geterrmsg(hcl));
|
||||
hcl_close (hcl);
|
||||
return -1;
|
||||
}
|
||||
HCL_OBJ_SET_FLAGS_KERNEL (xtn->sym_errstr, 1);
|
||||
}
|
||||
|
||||
while (1)
|
||||
{
|
||||
hcl_oop_t obj;
|
||||
/*
|
||||
static int count = 0;
|
||||
if (count %5 == 0) hcl_reset (hcl);
|
||||
count++;
|
||||
*/
|
||||
|
||||
obj = hcl_read(hcl);
|
||||
if (!obj)
|
||||
@ -1747,6 +1773,17 @@ int main (int argc, char* argv[])
|
||||
else
|
||||
{
|
||||
hcl_logbfmt (hcl, HCL_LOG_STDERR, "OK: EXITED WITH %O\n", retv);
|
||||
|
||||
/*
|
||||
* print the value of ERRSTR.
|
||||
hcl_oop_cons_t cons = hcl_getatsysdic(hcl, xtn->sym_errstr);
|
||||
if (cons)
|
||||
{
|
||||
HCL_ASSERT (hcl, HCL_IS_CONS(hcl, cons));
|
||||
HCL_ASSERT (hcl, HCL_CONS_CAR(cons) == xtn->sym_errstr);
|
||||
hcl_print (hcl, HCL_CONS_CDR(cons));
|
||||
}
|
||||
*/
|
||||
}
|
||||
//cancel_tick();
|
||||
g_hcl = HCL_NULL;
|
||||
@ -1774,6 +1811,7 @@ int main (int argc, char* argv[])
|
||||
hcl_logbfmt (hcl, HCL_LOG_STDERR, "EXECUTION OK - EXITED WITH %O\n", retv);
|
||||
}
|
||||
|
||||
|
||||
//cancel_tick();
|
||||
g_hcl = HCL_NULL;
|
||||
/*hcl_dumpsymtab (hcl);*/
|
||||
|
@ -488,7 +488,7 @@ int hcl_addbuiltinprims (hcl_t* hcl)
|
||||
/* turn on the kernel bit in the symbol associated with a primitive
|
||||
* function. 'set' prevents this symbol from being used as a variable
|
||||
* name */
|
||||
HCL_OBJ_SET_FLAGS_KERNEL (name, 1);
|
||||
HCL_OBJ_SET_FLAGS_KERNEL (name, 2);
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
44
lib/read.c
44
lib/read.c
@ -2091,31 +2091,59 @@ static int read_object (hcl_t* hcl)
|
||||
|
||||
case HCL_IOTOK_IDENT_DOTTED:
|
||||
obj = hcl_makesymbol(hcl, TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl));
|
||||
if (obj)
|
||||
if (obj && !hcl_getatsysdic(hcl, obj))
|
||||
{
|
||||
/* query the module for information if it is the first time
|
||||
* when the dotted symbol is seen */
|
||||
|
||||
hcl_pfbase_t* pfbase;
|
||||
hcl_mod_t* mod;
|
||||
hcl_oop_t prim;
|
||||
|
||||
hcl_oop_t val;
|
||||
unsigned int kernel_bits;
|
||||
|
||||
pfbase = hcl_querymod(hcl, TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl), &mod);
|
||||
if (!pfbase)
|
||||
{
|
||||
/* TODO switch to syntax error */
|
||||
return -1;
|
||||
}
|
||||
|
||||
|
||||
hcl_pushtmp (hcl, &obj);
|
||||
prim = hcl_makeprim(hcl, pfbase->handler, pfbase->minargs, pfbase->maxargs, mod);
|
||||
switch (pfbase->type)
|
||||
{
|
||||
case HCL_PFBASE_FUNC:
|
||||
kernel_bits = 2;
|
||||
val = hcl_makeprim(hcl, pfbase->handler, pfbase->minargs, pfbase->maxargs, mod);
|
||||
break;
|
||||
|
||||
if (!prim || !hcl_putatsysdic(hcl, obj, prim))
|
||||
case HCL_PFBASE_VAR:
|
||||
kernel_bits = 1;
|
||||
val = hcl->_nil;
|
||||
break;
|
||||
|
||||
case HCL_PFBASE_CONST:
|
||||
/* TODO: create a value from the pfbase information. it needs to get extended first
|
||||
* can i make use of pfbase->handler type-cast to a differnt type? */
|
||||
kernel_bits = 2;
|
||||
val = hcl->_nil;
|
||||
break;
|
||||
|
||||
default:
|
||||
hcl_poptmp (hcl);
|
||||
hcl_seterrbfmt (hcl, HCL_EINVAL, "invalid pfbase type - %d\n", pfbase->type);
|
||||
return -1;
|
||||
}
|
||||
|
||||
if (!val || !hcl_putatsysdic(hcl, obj, val))
|
||||
{
|
||||
hcl_poptmp (hcl);
|
||||
return -1;
|
||||
}
|
||||
|
||||
hcl_poptmp (hcl);
|
||||
|
||||
HCL_OBJ_SET_FLAGS_KERNEL (obj, 1);
|
||||
/* make this dotted symbol special that it can't get changed
|
||||
* to a different value */
|
||||
HCL_OBJ_SET_FLAGS_KERNEL (obj, kernel_bits);
|
||||
}
|
||||
break;
|
||||
}
|
||||
|
@ -105,10 +105,10 @@ static hcl_pfrc_t pf_arr_size (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
|
||||
|
||||
static hcl_pfinfo_t pfinfos[] =
|
||||
{
|
||||
{ { 'g','e','t','\0' }, 0, { pf_arr_get, 2, 2 } },
|
||||
/* { { 'm','a','k','e','\0' }, 0, { pf_arr_make, 1, 1 } },*/
|
||||
{ { 'p','u','t','\0' }, 0, { pf_arr_put, 3, 3 } },
|
||||
{ { 's','i','z','e','\0' }, 0, { pf_arr_size, 1, 1 } },
|
||||
{ { 'g','e','t','\0' }, { HCL_PFBASE_FUNC, pf_arr_get, 2, 2 } },
|
||||
/* { { 'm','a','k','e','\0' }, { HCL_PFBASE_FUNC, pf_arr_make, 1, 1 } },*/
|
||||
{ { 'p','u','t','\0' }, { HCL_PFBASE_FUNC, pf_arr_put, 3, 3 } },
|
||||
{ { 's','i','z','e','\0' }, { HCL_PFBASE_FUNC, pf_arr_size, 1, 1 } },
|
||||
};
|
||||
|
||||
/* ------------------------------------------------------------------------ */
|
||||
|
@ -110,10 +110,10 @@ static hcl_pfrc_t pf_dic_walk (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
|
||||
|
||||
static hcl_pfinfo_t pfinfos[] =
|
||||
{
|
||||
{ { 'g','e','t','\0' }, 0, { pf_dic_get, 2, 2 } },
|
||||
/* { { 'm','a','k','e','\0' }, 0, { pf_dic_make, 1, 1 } }, */
|
||||
{ { 'p','u','t','\0' }, 0, { pf_dic_put, 3, 3 } },
|
||||
{ { 'w','a','l','k','\0' }, 0, { pf_dic_walk, 2, 2 } },
|
||||
{ { 'g','e','t','\0' }, { HCL_PFBASE_FUNC, pf_dic_get, 2, 2 } },
|
||||
/* { { 'm','a','k','e','\0' }, { HCL_PFBASE_FUNC, pf_dic_make, 1, 1 } }, */
|
||||
{ { 'p','u','t','\0' }, { HCL_PFBASE_FUNC, pf_dic_put, 3, 3 } },
|
||||
{ { 'w','a','l','k','\0' }, { HCL_PFBASE_FUNC, pf_dic_walk, 2, 2 } },
|
||||
};
|
||||
|
||||
/* ------------------------------------------------------------------------ */
|
||||
|
@ -47,7 +47,8 @@ static hcl_pfrc_t pf_str_length (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
|
||||
|
||||
static hcl_pfinfo_t pfinfos[] =
|
||||
{
|
||||
{ { 'l','e','n','g','t','h','\0' }, 0, { pf_str_length, 1, 1 } }
|
||||
/*{ { 'V','A','R','\0' }, { HCL_PFBASE_VAR, HCL_NULL, 0, 0 } },*/
|
||||
{ { 'l','e','n','g','t','h','\0' }, { HCL_PFBASE_FUNC, pf_str_length, 1, 1 } }
|
||||
};
|
||||
|
||||
/* ------------------------------------------------------------------------ */
|
||||
|
Loading…
Reference in New Issue
Block a user