diff --git a/lib/comp.c b/lib/comp.c index 72d60fe..a17930f 100644 --- a/lib/comp.c +++ b/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 */ - tmp = hcl_remakengcarray (hcl, (hcl_oop_t)hcl->code.lit.arr, newcapa); + newcapa = HCL_ALIGN(capa + 1, HCL_LIT_BUFFER_ALIGN); + 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; } diff --git a/lib/dic.c b/lib/dic.c index 1218d80..edd4b17 100644 --- a/lib/dic.c +++ b/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; diff --git a/lib/gc.c b/lib/gc.c index e019d34..8d041d8 100644 --- a/lib/gc.c +++ b/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; diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index 79179c2..474b1e1 100644 --- a/lib/hcl-prv.h +++ b/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)) diff --git a/lib/hcl.c b/lib/hcl.c index adbd6fe..39194e4 100644 --- a/lib/hcl.c +++ b/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) diff --git a/lib/hcl.h b/lib/hcl.h index 385b80b..b332140 100644 --- a/lib/hcl.h +++ b/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; } @@ -1390,8 +1394,8 @@ HCL_EXPORT void hcl_seterrnum ( ); HCL_EXPORT void hcl_seterrwithsyserr ( - hcl_t* hcl, - int syserr + hcl_t* hcl, + int syserr ); HCL_EXPORT void hcl_seterrbfmt (