hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

renamed hcl_purgeatdic() to hcl_zapatdic()

Browse Source 
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:
hyung-hwan 2018-03-08 14:18:30 +00:00
parent 02b02865ac
commit a60bd0c898
13 changed files with 186 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
lib/comp.c
View File

@ -868,7 +868,7 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src, int defun)
return -1; 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, 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 */ "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; 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, hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDARGNAME, HCL_NULL, HCL_NULL,
"special symbol not to be declared as an argument - %O", arg); /* TOOD: error location */ "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++) for (i = 0; i < sz; i++)
{ {
if (HCL_OBJ_GET_FLAGS_SYNCODE(((hcl_oop_oop_t)dcl)->slot[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, hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_NULL, HCL_NULL,
"special symbol not to be declared as a variable - %O", obj); /* TOOD: error location */ "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; 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 */ 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; return -1;

42
lib/dic.c
View File

@ -92,7 +92,11 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc)
return newbuc; 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) 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_ooi_t tally;
hcl_oow_t index; 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) #if defined(SYMBOL_ONLY_KEY)
index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket); index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket);
#else #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); index %= HCL_OBJ_GET_SIZE(dic->bucket);
#endif #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]; ass = (hcl_oop_cons_t)dic->bucket->slot[index];
HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass)); 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) return HCL_NULL;
if (n >= 1) 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 */ /* recalculate the index for the expanded bucket */
index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket); index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket);
#else #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); index %= HCL_OBJ_GET_SIZE(dic->bucket);
#endif #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 /* create a new assocation of a key and a value since
* the key isn't found in the root dictionary */ * 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; if (!ass) goto oops;
/* the current tally must be less than the maximum value. otherwise, /* 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) #if defined(SYMBOL_ONLY_KEY)
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
#endif #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) 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) #if defined(SYMBOL_ONLY_KEY)
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
#endif #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) 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) #if defined(SYMBOL_ONLY_KEY)
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
#endif #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) 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) #if defined(SYMBOL_ONLY_KEY)
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
#endif #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_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; hcl_oop_cons_t ass;
tally = HCL_OOP_TO_SMOOI(dic->tally); 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) #if defined(SYMBOL_ONLY_KEY)
index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % bs; index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % bs;
#else #else
if (hcl_hashobj(hcl, (hcl_oop_t)key, &index) <= -1) return -1; if (hcl_hashobj(hcl, key, &index) <= -1) return -1;
index %= bs; index %= bs;
#endif #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)); HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,ass->car));
if (HCL_OBJ_GET_SIZE(key) == HCL_OBJ_GET_SIZE(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. */ /* the value of HCL_NULL indicates no insertion or update. */
goto found; 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; if (n >= 1) goto found;
#endif #endif
index = (index + 1) % HCL_OBJ_GET_SIZE(dic->bucket); index = (index + 1) % bs;
} }
hcl_seterrnum (hcl, HCL_ENOENT); hcl_seterrnum (hcl, HCL_ENOENT);
@ -323,10 +335,10 @@ found:
#if defined(SYMBOL_ONLY_KEY) #if defined(SYMBOL_ONLY_KEY)
/* get the natural hash index for the data in the slot at /* get the natural hash index for the data in the slot at
* the current hash index */ * 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 #else
if (hcl_hashobj(hcl, ass->car, &z) <= -1) return -1; if (hcl_hashobj(hcl, ass->car, &z) <= -1) return -1;
index %= bs; z %= bs;
#endif #endif
/* move an element if necesary */ /* move an element if necesary */

6
lib/exec.c
View File

@ -1165,12 +1165,12 @@ static int execute (hcl_t* hcl)
}*/ }*/
/* TODO: implement different process switching scheme - time-slice or clock based??? */ /* 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); } if (!hcl->proc_switched && hcl->switch_proc) { switch_to_next_runnable_process (hcl); }
hcl->switch_proc = 0; hcl->switch_proc = 0;
#else #else
if (!hcl->proc_switched) { switch_to_next_runnable_process (hcl); } if (!hcl->proc_switched) { switch_to_next_runnable_process (hcl); }
#endif #endif
hcl->proc_switched = 0; hcl->proc_switched = 0;

1
lib/gc.c
View File

@ -539,5 +539,6 @@ int hcl_ignite (hcl_t* hcl)
} }
hcl->p.e = hcl->_nil; hcl->p.e = hcl->_nil;
return 0; return 0;
} }

9
lib/hcl-prv.h
View File

@ -718,15 +718,6 @@ void* hcl_allocheapmem (
hcl_oow_t size hcl_oow_t size
); );
/* ========================================================================= */
/* gc.c */
/* ========================================================================= */
hcl_oop_t hcl_moveoop (
hcl_t* hcl,
hcl_oop_t oop
);
/* ========================================================================= */ /* ========================================================================= */
/* obj.c */ /* obj.c */
/* ========================================================================= */ /* ========================================================================= */

20
lib/hcl.c
View File

@ -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_oop_t v;
hcl_oow_t i; hcl_oow_t i;
#if 0 /* delete all literals shown in the literal frame from the system dictionary
/* clear global variables -> especially lambdas, because they refer to the byte codes? */ * excluding special kernel symbols. */
for (i = 0; i < hcl->code.lit.len; i++) for (i = 0; i < hcl->code.lit.len; i++)
{ {
v = ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[ip]); v = ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[i];
if (HCL_IS_CONS(v)) 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.bc.len = 0;
hcl->code.lit.len = 0; hcl->code.lit.len = 0;
/* clean up object memory */
hcl_gc (hcl); hcl_gc (hcl);
} }

64
lib/hcl.h
View File

@ -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 * item than the value of the size field. used for a
* terminating null in a variable-char object. internel * terminating null in a variable-char object. internel
* use only. * use only.
* kernel: 0 or 1. indicates that the object is a kernel object. * kernel: 0 - ordinary object.
* VM disallows layout changes of a kernel object. * 1 - kernel object. can survive hcl_reset().
* internal use only. * 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. * moved: 0 or 1. used by GC. internal use only.
* ngc: 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 * 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) ( typedef hcl_pfrc_t (*hcl_pfimpl_t) (
hcl_t* hcl, hcl_t* hcl,
hcl_mod_t* mod, 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; typedef struct hcl_pfbase_t hcl_pfbase_t;
struct hcl_pfbase_t struct hcl_pfbase_t
{ {
hcl_pfimpl_t handler; hcl_pfbase_type_t type;
hcl_oow_t minargs; hcl_pfimpl_t handler;
hcl_oow_t maxargs; hcl_oow_t minargs;
hcl_oow_t maxargs;
}; };
typedef struct hcl_pfinfo_t hcl_pfinfo_t; typedef struct hcl_pfinfo_t hcl_pfinfo_t;
struct hcl_pfinfo_t struct hcl_pfinfo_t
{ {
hcl_ooch_t mthname[32]; hcl_ooch_t mthname[32];
int variadic;
hcl_pfbase_t base; hcl_pfbase_t base;
}; };
/* ========================================================================= /* =========================================================================
@ -1364,10 +1374,17 @@ HCL_EXPORT void hcl_fini (
hcl_t* hcl 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 hcl_t* hcl
);*/ );
#if defined(HCL_HAVE_INLINE) #if defined(HCL_HAVE_INLINE)
static HCL_INLINE hcl_mmgr_t* hcl_getmmgr (hcl_t* hcl) { return hcl->mmgr; } 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 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_EXPORT hcl_oow_t hcl_getpayloadbytes (
hcl_t* hcl, hcl_t* hcl,
hcl_oop_t oop hcl_oop_t oop
@ -1814,6 +1844,11 @@ HCL_EXPORT hcl_oop_cons_t hcl_getatsysdic (
hcl_oop_t key 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_EXPORT hcl_oop_cons_t hcl_putatdic (
hcl_t* hcl, hcl_t* hcl,
hcl_oop_dic_t dic, hcl_oop_dic_t dic,
@ -1827,6 +1862,13 @@ HCL_EXPORT hcl_oop_cons_t hcl_getatdic (
hcl_oop_t key 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_EXPORT int hcl_walkdic (
hcl_t* hcl, hcl_t* hcl,
hcl_oop_dic_t dic, hcl_oop_dic_t dic,

40
lib/main.c
View File

@ -146,6 +146,8 @@ struct xtn_t
int logfd_istty; int logfd_istty;
int reader_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) static void fini_hcl (hcl_t* hcl)
{ {
xtn_t* xtn = (xtn_t*)hcl_getxtn(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)); memset (&hclcb, 0, HCL_SIZEOF(hclcb));
hclcb.fini = fini_hcl; hclcb.fini = fini_hcl;
hclcb.gc = gc_hcl;
hcl_regcb (hcl, &hclcb); hcl_regcb (hcl, &hclcb);
@ -1676,14 +1685,31 @@ int main (int argc, char* argv[])
if (hcl_attachio(hcl, read_handler, print_handler) <= -1) 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); hcl_close (hcl);
return -1; 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) while (1)
{ {
hcl_oop_t obj; hcl_oop_t obj;
/*
static int count = 0;
if (count %5 == 0) hcl_reset (hcl);
count++;
*/
obj = hcl_read(hcl); obj = hcl_read(hcl);
if (!obj) if (!obj)
@ -1747,6 +1773,17 @@ int main (int argc, char* argv[])
else else
{ {
hcl_logbfmt (hcl, HCL_LOG_STDERR, "OK: EXITED WITH %O\n", retv); 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(); //cancel_tick();
g_hcl = HCL_NULL; 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); hcl_logbfmt (hcl, HCL_LOG_STDERR, "EXECUTION OK - EXITED WITH %O\n", retv);
} }
//cancel_tick(); //cancel_tick();
g_hcl = HCL_NULL; g_hcl = HCL_NULL;
/*hcl_dumpsymtab (hcl);*/ /*hcl_dumpsymtab (hcl);*/

2
lib/prim.c
View File

@ -488,7 +488,7 @@ int hcl_addbuiltinprims (hcl_t* hcl)
/* turn on the kernel bit in the symbol associated with a primitive /* turn on the kernel bit in the symbol associated with a primitive
* function. 'set' prevents this symbol from being used as a variable * function. 'set' prevents this symbol from being used as a variable
* name */ * name */
HCL_OBJ_SET_FLAGS_KERNEL (name, 1); HCL_OBJ_SET_FLAGS_KERNEL (name, 2);
} }
return 0; return 0;

40
lib/read.c
View File

@ -2091,11 +2091,15 @@ static int read_object (hcl_t* hcl)
case HCL_IOTOK_IDENT_DOTTED: case HCL_IOTOK_IDENT_DOTTED:
obj = hcl_makesymbol(hcl, TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl)); 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_pfbase_t* pfbase;
hcl_mod_t* mod; 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); pfbase = hcl_querymod(hcl, TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl), &mod);
if (!pfbase) if (!pfbase)
@ -2105,17 +2109,41 @@ static int read_object (hcl_t* hcl)
} }
hcl_pushtmp (hcl, &obj); 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); hcl_poptmp (hcl);
return -1; return -1;
} }
hcl_poptmp (hcl); 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; break;
} }

8
mod/arr.c
View File

@ -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[] = static hcl_pfinfo_t pfinfos[] =
{ {
{ { 'g','e','t','\0' }, 0, { pf_arr_get, 2, 2 } }, { { 'g','e','t','\0' }, { HCL_PFBASE_FUNC, pf_arr_get, 2, 2 } },
/* { { 'm','a','k','e','\0' }, 0, { pf_arr_make, 1, 1 } },*/ /* { { 'm','a','k','e','\0' }, { HCL_PFBASE_FUNC, pf_arr_make, 1, 1 } },*/
{ { 'p','u','t','\0' }, 0, { pf_arr_put, 3, 3 } }, { { 'p','u','t','\0' }, { HCL_PFBASE_FUNC, pf_arr_put, 3, 3 } },
{ { 's','i','z','e','\0' }, 0, { pf_arr_size, 1, 1 } }, { { 's','i','z','e','\0' }, { HCL_PFBASE_FUNC, pf_arr_size, 1, 1 } },
}; };
/* ------------------------------------------------------------------------ */ /* ------------------------------------------------------------------------ */

8
mod/dic.c
View File

@ -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[] = static hcl_pfinfo_t pfinfos[] =
{ {
{ { 'g','e','t','\0' }, 0, { pf_dic_get, 2, 2 } }, { { 'g','e','t','\0' }, { HCL_PFBASE_FUNC, pf_dic_get, 2, 2 } },
/* { { 'm','a','k','e','\0' }, 0, { pf_dic_make, 1, 1 } }, */ /* { { 'm','a','k','e','\0' }, { HCL_PFBASE_FUNC, pf_dic_make, 1, 1 } }, */
{ { 'p','u','t','\0' }, 0, { pf_dic_put, 3, 3 } }, { { 'p','u','t','\0' }, { HCL_PFBASE_FUNC, pf_dic_put, 3, 3 } },
{ { 'w','a','l','k','\0' }, 0, { pf_dic_walk, 2, 2 } }, { { 'w','a','l','k','\0' }, { HCL_PFBASE_FUNC, pf_dic_walk, 2, 2 } },
}; };
/* ------------------------------------------------------------------------ */ /* ------------------------------------------------------------------------ */

3
mod/str.c
View File

@ -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[] = 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 } }
}; };
/* ------------------------------------------------------------------------ */ /* ------------------------------------------------------------------------ */