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

implemented dictionary printing

Browse Source
This commit is contained in:
hyung-hwan 2018-02-07 10:55:20 +00:00
parent 979ba97769
commit f904914d6a
11 changed files with 247 additions and 173 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
lib/comp.c
View File

@ -263,7 +263,7 @@ static int emit_single_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1
case HCL_CODE_PUSH_NEGINTLIT: case HCL_CODE_PUSH_NEGINTLIT:
case HCL_CODE_PUSH_CHARLIT: case HCL_CODE_PUSH_CHARLIT:
case HCL_CODE_MAKE_DICTIONARY: /* TODO: don't these need write_long2? */ case HCL_CODE_MAKE_DIC: /* TODO: don't these need write_long2? */
case HCL_CODE_MAKE_ARRAY: case HCL_CODE_MAKE_ARRAY:
case HCL_CODE_POP_INTO_ARRAY: case HCL_CODE_POP_INTO_ARRAY:
bc = cmd; bc = cmd;
@ -616,7 +616,7 @@ enum
COP_COMPILE_IF_OBJECT_LIST_TAIL, COP_COMPILE_IF_OBJECT_LIST_TAIL,
COP_COMPILE_ARRAY_LIST, COP_COMPILE_ARRAY_LIST,
COP_COMPILE_DICTIONARY_LIST, COP_COMPILE_DIC_LIST,
COP_SUBCOMPILE_ELIF, COP_SUBCOMPILE_ELIF,
COP_SUBCOMPILE_ELSE, COP_SUBCOMPILE_ELSE,
@ -624,9 +624,9 @@ enum
COP_EMIT_CALL, COP_EMIT_CALL,
COP_EMIT_MAKE_ARRAY, COP_EMIT_MAKE_ARRAY,
COP_EMIT_MAKE_DICTIONARY, COP_EMIT_MAKE_DIC,
COP_EMIT_POP_INTO_ARRAY, COP_EMIT_POP_INTO_ARRAY,
COP_EMIT_POP_INTO_DICTIONARY, COP_EMIT_POP_INTO_DIC,
COP_EMIT_LAMBDA, COP_EMIT_LAMBDA,
COP_EMIT_POP_STACKTOP, COP_EMIT_POP_STACKTOP,
@ -1132,14 +1132,13 @@ static int compile_cons_array_expression (hcl_t* hcl, hcl_oop_t obj)
return 0; return 0;
} }
static int compile_cons_dictionary_expression (hcl_t* hcl, hcl_oop_t obj) static int compile_cons_dic_expression (hcl_t* hcl, hcl_oop_t obj)
{ {
/* #{ } */ /* #{ } */
hcl_ooi_t nargs; hcl_ooi_t nargs;
hcl_cframe_t* cf; hcl_cframe_t* cf;
printf ("XXXXXXXXXXXXXx\n"); SWITCH_TOP_CFRAME (hcl, COP_EMIT_MAKE_DIC, HCL_SMOOI_TO_OOP(0));
SWITCH_TOP_CFRAME (hcl, COP_EMIT_MAKE_DICTIONARY, HCL_SMOOI_TO_OOP(0));
nargs = hcl_countcons(hcl, obj); nargs = hcl_countcons(hcl, obj);
if (nargs > MAX_CODE_PARAM) if (nargs > MAX_CODE_PARAM)
@ -1150,11 +1149,11 @@ printf ("XXXXXXXXXXXXXx\n");
} }
/* redundant cdr check is performed inside compile_object_list() */ /* redundant cdr check is performed inside compile_object_list() */
PUSH_SUBCFRAME (hcl, COP_COMPILE_DICTIONARY_LIST, obj); PUSH_SUBCFRAME (hcl, COP_COMPILE_DIC_LIST, obj);
/* patch the argument count in the operand field of the COP_MAKE_DICTIONARY frame */ /* patch the argument count in the operand field of the COP_MAKE_DIC frame */
cf = GET_TOP_CFRAME(hcl); cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_DICTIONARY); HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_DIC);
cf->operand = HCL_SMOOI_TO_OOP(nargs); cf->operand = HCL_SMOOI_TO_OOP(nargs);
return 0; return 0;
@ -1412,8 +1411,8 @@ static int compile_object (hcl_t* hcl)
if (compile_cons_bytearray_expression (hcl, cf->operand) <= -1) return -1; if (compile_cons_bytearray_expression (hcl, cf->operand) <= -1) return -1;
break; break;
*/ */
case HCL_CONCODE_DICTIONARY: case HCL_CONCODE_DIC:
if (compile_cons_dictionary_expression(hcl, cf->operand) <= -1) return -1; if (compile_cons_dic_expression(hcl, cf->operand) <= -1) return -1;
break; break;
/* TODO: QLIST? */ /* TODO: QLIST? */
@ -1598,13 +1597,13 @@ static int compile_array_list (hcl_t* hcl)
return 0; return 0;
} }
static int compile_dictionary_list (hcl_t* hcl) static int compile_dic_list (hcl_t* hcl)
{ {
hcl_cframe_t* cf; hcl_cframe_t* cf;
hcl_oop_t coperand; hcl_oop_t coperand;
cf = GET_TOP_CFRAME(hcl); cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_DICTIONARY_LIST); HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_DIC_LIST);
coperand = cf->operand; coperand = cf->operand;
@ -1641,10 +1640,10 @@ static int compile_dictionary_list (hcl_t* hcl)
if (!HCL_IS_NIL(hcl, cddr)) if (!HCL_IS_NIL(hcl, cddr))
{ {
PUSH_SUBCFRAME (hcl, COP_COMPILE_DICTIONARY_LIST, cddr); PUSH_SUBCFRAME (hcl, COP_COMPILE_DIC_LIST, cddr);
} }
PUSH_SUBCFRAME (hcl, COP_EMIT_POP_INTO_DICTIONARY, HCL_SMOOI_TO_OOP(0)); PUSH_SUBCFRAME (hcl, COP_EMIT_POP_INTO_DIC, HCL_SMOOI_TO_OOP(0));
PUSH_SUBCFRAME(hcl, COP_COMPILE_OBJECT, cadr); PUSH_SUBCFRAME(hcl, COP_COMPILE_OBJECT, cadr);
} }
@ -1978,16 +1977,16 @@ static HCL_INLINE int emit_make_array (hcl_t* hcl)
} }
static HCL_INLINE int emit_make_dictionary (hcl_t* hcl) static HCL_INLINE int emit_make_dic (hcl_t* hcl)
{ {
hcl_cframe_t* cf; hcl_cframe_t* cf;
int n; int n;
cf = GET_TOP_CFRAME(hcl); cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_DICTIONARY); HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_DIC);
HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand));
n = emit_single_param_instruction (hcl, HCL_CODE_MAKE_DICTIONARY, HCL_OOP_TO_SMOOI(cf->operand)); n = emit_single_param_instruction (hcl, HCL_CODE_MAKE_DIC, HCL_OOP_TO_SMOOI(cf->operand));
POP_CFRAME (hcl); POP_CFRAME (hcl);
return n; return n;
@ -2008,15 +2007,15 @@ static HCL_INLINE int emit_pop_into_array (hcl_t* hcl)
return n; return n;
} }
static HCL_INLINE int emit_pop_into_dictionary (hcl_t* hcl) static HCL_INLINE int emit_pop_into_dic (hcl_t* hcl)
{ {
hcl_cframe_t* cf; hcl_cframe_t* cf;
int n; int n;
cf = GET_TOP_CFRAME(hcl); cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_INTO_DICTIONARY); HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_INTO_DIC);
n = emit_byte_instruction (hcl, HCL_CODE_POP_INTO_DICTIONARY); n = emit_byte_instruction (hcl, HCL_CODE_POP_INTO_DIC);
POP_CFRAME (hcl); POP_CFRAME (hcl);
return n; return n;
@ -2178,8 +2177,8 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
if (compile_array_list(hcl) <= -1) goto oops; if (compile_array_list(hcl) <= -1) goto oops;
break; break;
case COP_COMPILE_DICTIONARY_LIST: case COP_COMPILE_DIC_LIST:
if (compile_dictionary_list(hcl) <= -1) goto oops; if (compile_dic_list(hcl) <= -1) goto oops;
break; break;
case COP_EMIT_CALL: case COP_EMIT_CALL:
@ -2190,16 +2189,16 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
if (emit_make_array(hcl) <= -1) goto oops; if (emit_make_array(hcl) <= -1) goto oops;
break; break;
case COP_EMIT_MAKE_DICTIONARY: case COP_EMIT_MAKE_DIC:
if (emit_make_dictionary(hcl) <= -1) goto oops; if (emit_make_dic(hcl) <= -1) goto oops;
break; break;
case COP_EMIT_POP_INTO_ARRAY: case COP_EMIT_POP_INTO_ARRAY:
if (emit_pop_into_array(hcl) <= -1) goto oops; if (emit_pop_into_array(hcl) <= -1) goto oops;
break; break;
case COP_EMIT_POP_INTO_DICTIONARY: case COP_EMIT_POP_INTO_DIC:
if (emit_pop_into_dictionary(hcl) <= -1) goto oops; if (emit_pop_into_dic(hcl) <= -1) goto oops;
break; break;
case COP_EMIT_LAMBDA: case COP_EMIT_LAMBDA:

2
lib/debug.c
View File

@ -47,7 +47,7 @@ void hcl_dumpsymtab (hcl_t* hcl)
HCL_DEBUG0 (hcl, "--------------------------------------------\n"); HCL_DEBUG0 (hcl, "--------------------------------------------\n");
} }
void hcl_dumpdic (hcl_t* hcl, hcl_oop_set_t dic, const hcl_bch_t* title) void hcl_dumpdic (hcl_t* hcl, hcl_oop_dic_t dic, const hcl_bch_t* title)
{ {
hcl_oow_t i; hcl_oow_t i;
hcl_oop_cons_t ass; hcl_oop_cons_t ass;

8
lib/decode.c
View File

@ -503,13 +503,13 @@ int hcl_decode (hcl_t* hcl, hcl_ooi_t start, hcl_ooi_t end)
LOG_INST_1 (hcl, "pop_into_array %zu", b1); LOG_INST_1 (hcl, "pop_into_array %zu", b1);
break; break;
case HCL_CODE_MAKE_DICTIONARY: case HCL_CODE_MAKE_DIC:
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "make_dictionary %zu", b1); LOG_INST_1 (hcl, "make_dic %zu", b1);
break; break;
case HCL_CODE_POP_INTO_DICTIONARY: case HCL_CODE_POP_INTO_DIC:
LOG_INST_0 (hcl, "pop_into_dictionary"); LOG_INST_0 (hcl, "pop_into_dic");
break; break;
/* -------------------------------------------------------- */ /* -------------------------------------------------------- */

124
lib/dic.c
View File

@ -26,6 +26,8 @@
#include "hcl-prv.h" #include "hcl-prv.h"
/*#define SYMBOL_ONLY_KEY */
static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc) static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc)
{ {
hcl_oop_oop_t newbuc; hcl_oop_oop_t newbuc;
@ -71,12 +73,18 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc)
ass = (hcl_oop_cons_t)oldbuc->slot[--oldsz]; ass = (hcl_oop_cons_t)oldbuc->slot[--oldsz];
if ((hcl_oop_t)ass != hcl->_nil) if ((hcl_oop_t)ass != hcl->_nil)
{ {
#if defined(SYMBOL_ONLY_KEY)
HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass)); HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass));
key = (hcl_oop_char_t)ass->car; key = (hcl_oop_char_t)ass->car;
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % newsz; index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % newsz;
#else
int n;
HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass));
n = hcl_hashobj(hcl, ass->car, &index);
HCL_ASSERT (hcl, n == 0); /* since it's expanding, the existing in the bucket should always be hashable */
index %= newsz;
#endif
while (newbuc->slot[index] != hcl->_nil) index = (index + 1) % newsz; while (newbuc->slot[index] != hcl->_nil) index = (index + 1) % newsz;
newbuc->slot[index] = (hcl_oop_t)ass; newbuc->slot[index] = (hcl_oop_t)ass;
} }
@ -85,7 +93,7 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc)
return newbuc; return newbuc;
} }
static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_set_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)
{ {
hcl_ooi_t tally; hcl_ooi_t tally;
hcl_oow_t index; hcl_oow_t index;
@ -94,17 +102,24 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_set_t dic, hcl_oop_cha
/* the system dictionary is not a generic dictionary. /* the system dictionary is not a generic dictionary.
* it accepts only a symbol as a key. */ * it accepts only a symbol as a key. */
#if defined(SYMBOL_ONLY_KEY)
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
#endif
HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(dic->tally)); HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(dic->tally));
HCL_ASSERT (hcl, HCL_IS_ARRAY(hcl,dic->bucket)); HCL_ASSERT (hcl, HCL_IS_ARRAY(hcl,dic->bucket));
#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
if (hcl_hashobj(hcl, key, &index) <= -1) return HCL_NULL;
index %= HCL_OBJ_GET_SIZE(dic->bucket);
#endif
/* find */ /* find */
while (dic->bucket->slot[index] != hcl->_nil) while (dic->bucket->slot[index] != hcl->_nil)
{ {
#if defined(SYMBOL_ONLY_KEY)
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));
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,ass->car)); HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,ass->car));
@ -115,6 +130,21 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_set_t dic, hcl_oop_cha
if (value) ass->cdr = value; /* update */ if (value) ass->cdr = value; /* update */
return ass; return ass;
} }
#else
int n;
ass = (hcl_oop_cons_t)dic->bucket->slot[index];
HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass));
n = hcl_equalobjs(hcl, key, ass->car);
if (n <= -1) return HCL_NULL;
if (n >= 1)
{
/* the value of HCL_NULL indicates no insertion or update. */
if (value) ass->cdr = value; /* update */
return ass;
}
#endif
index = (index + 1) % HCL_OBJ_GET_SIZE(dic->bucket); index = (index + 1) % HCL_OBJ_GET_SIZE(dic->bucket);
} }
@ -123,7 +153,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_set_t dic, hcl_oop_cha
{ {
/* when value is HCL_NULL, perform no insertion. /* when value is HCL_NULL, perform no insertion.
* the value of HCL_NULL indicates no insertion or update. */ * the value of HCL_NULL indicates no insertion or update. */
hcl_seterrnum (hcl, HCL_ENOENT); hcl_seterrbfmt (hcl, HCL_ENOENT, "key not found - %O", key);
return HCL_NULL; return HCL_NULL;
} }
@ -151,8 +181,8 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_set_t dic, hcl_oop_cha
hcl_oop_oop_t bucket; hcl_oop_oop_t bucket;
/* TODO: make the growth policy configurable instead of growing /* TODO: make the growth policy configurable instead of growing
it just before it gets full. The polcy can be grow it it just before it gets full. The polcy can be grow it
if it's 70% full */ if it's 70% full */
/* enlarge the bucket before it gets full to /* enlarge the bucket before it gets full to
* make sure that it has at least one free slot left * make sure that it has at least one free slot left
@ -163,8 +193,13 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_set_t dic, hcl_oop_cha
dic->bucket = bucket; dic->bucket = bucket;
#if defined(SYMBOL_ONLY_KEY)
/* 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
hcl_hashobj(hcl, key, &index); /* this must succeed as i know 'key' is hashable */
index %= HCL_OBJ_GET_SIZE(dic->bucket);
#endif
while (dic->bucket->slot[index] != hcl->_nil) while (dic->bucket->slot[index] != hcl->_nil)
index = (index + 1) % HCL_OBJ_GET_SIZE(dic->bucket); index = (index + 1) % HCL_OBJ_GET_SIZE(dic->bucket);
@ -189,75 +224,56 @@ oops:
return HCL_NULL; return HCL_NULL;
} }
static hcl_oop_cons_t lookup (hcl_t* hcl, hcl_oop_set_t dic, const hcl_oocs_t* name)
{
/* this is special version of hcl_getatsysdic() that performs
* lookup using a plain string specified */
hcl_oow_t index;
hcl_oop_cons_t ass;
HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(dic->tally));
HCL_ASSERT (hcl, HCL_IS_ARRAY(hcl,dic->bucket));
index = hcl_hashoochars(name->ptr, name->len) % HCL_OBJ_GET_SIZE(dic->bucket);
while (dic->bucket->slot[index] != hcl->_nil)
{
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 (name->len == HCL_OBJ_GET_SIZE(ass->car) &&
hcl_equaloochars(name->ptr, ((hcl_oop_char_t)ass->car)->slot, name->len))
{
return ass;
}
index = (index + 1) % HCL_OBJ_GET_SIZE(dic->bucket);
}
/* when value is HCL_NULL, perform no insertion */
hcl_seterrnum (hcl, HCL_ENOENT);
return HCL_NULL;
}
hcl_oop_cons_t hcl_putatsysdic (hcl_t* hcl, hcl_oop_t key, hcl_oop_t value) 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)); 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, (hcl_oop_char_t)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)
{ {
#if defined(SYMBOL_ONLY_KEY)
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,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, (hcl_oop_char_t)key, HCL_NULL);
} }
hcl_oop_cons_t hcl_lookupsysdic (hcl_t* hcl, const hcl_oocs_t* name) hcl_oop_cons_t hcl_putatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key, hcl_oop_t value)
{
return lookup (hcl, hcl->sysdic, name);
}
hcl_oop_cons_t hcl_putatdic (hcl_t* hcl, hcl_oop_set_t dic, hcl_oop_t key, hcl_oop_t value)
{ {
#if defined(SYMBOL_ONLY_KEY)
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,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, (hcl_oop_char_t)key, value);
} }
hcl_oop_cons_t hcl_getatdic (hcl_t* hcl, hcl_oop_set_t dic, hcl_oop_t key) 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)); 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, (hcl_oop_char_t)key, HCL_NULL);
} }
hcl_oop_cons_t hcl_lookupdic (hcl_t* hcl, hcl_oop_set_t dic, const hcl_oocs_t* name) hcl_oop_t hcl_makedic (hcl_t* hcl, hcl_oow_t inisize)
{ {
return lookup (hcl, dic, name); hcl_oop_dic_t obj;
}
hcl_oop_set_t hcl_makedic (hcl_t* hcl, hcl_oow_t size) obj = (hcl_oop_dic_t)hcl_allocoopobj (hcl, HCL_BRAND_DIC, 2);
{ if (obj)
return (hcl_oop_set_t)hcl_makeset (hcl, size); {
hcl_oop_oop_t bucket;
obj->tally = HCL_SMOOI_TO_OOP(0);
hcl_pushtmp (hcl, (hcl_oop_t*)&obj);
bucket = (hcl_oop_oop_t)hcl_makearray (hcl, inisize);
hcl_poptmp (hcl);
if (!bucket) obj = HCL_NULL;
else obj->bucket = bucket;
}
return (hcl_oop_t)obj;
} }

11
lib/exec.c
View File

@ -1842,30 +1842,29 @@ static int execute (hcl_t* hcl)
break; break;
} }
case HCL_CODE_MAKE_DICTIONARY: case HCL_CODE_MAKE_DIC:
{ {
hcl_oop_t t; hcl_oop_t t;
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "make_dictionary %zu", b1); LOG_INST_1 (hcl, "make_dic %zu", b1);
t = (hcl_oop_t)hcl_makedic (hcl, b1 + 10); t = (hcl_oop_t)hcl_makedic (hcl, b1 + 10);
if (!t) return -1; if (!t) return -1;
HCL_STACK_PUSH (hcl, t); HCL_STACK_PUSH (hcl, t);
break; break;
} }
case HCL_CODE_POP_INTO_DICTIONARY: case HCL_CODE_POP_INTO_DIC:
{ {
hcl_oop_t t1, t2, t3; hcl_oop_t t1, t2, t3;
LOG_INST_0 (hcl, "pop_into_dictionary"); LOG_INST_0 (hcl, "pop_into_dic");
t1 = HCL_STACK_GETTOP(hcl); /* value */ t1 = HCL_STACK_GETTOP(hcl); /* value */
HCL_STACK_POP (hcl); HCL_STACK_POP (hcl);
t2 = HCL_STACK_GETTOP(hcl); /* key */ t2 = HCL_STACK_GETTOP(hcl); /* key */
HCL_STACK_POP (hcl); HCL_STACK_POP (hcl);
t3 = HCL_STACK_GETTOP(hcl); /* dictionary */ t3 = HCL_STACK_GETTOP(hcl); /* dictionary */
/* TODO: generic dictioanry??? */ if (!hcl_putatdic (hcl, (hcl_oop_dic_t)t3, t2, t1)) return -1;
if (!hcl_putatdic (hcl, (hcl_oop_set_t)t3, t2, t1)) return -1;
break; break;
} }

8
lib/gc.c
View File

@ -327,7 +327,7 @@ void hcl_gc (hcl_t* hcl)
hcl->_large_positive_integer = hcl_moveoop (hcl, hcl->_large_positive_integer); hcl->_large_positive_integer = hcl_moveoop (hcl, hcl->_large_positive_integer);
hcl->_large_negative_integer = hcl_moveoop (hcl, hcl->_large_negative_integer); hcl->_large_negative_integer = hcl_moveoop (hcl, hcl->_large_negative_integer);
hcl->sysdic = (hcl_oop_set_t) hcl_moveoop (hcl, (hcl_oop_t)hcl->sysdic); hcl->sysdic = (hcl_oop_dic_t) hcl_moveoop (hcl, (hcl_oop_t)hcl->sysdic);
hcl->processor = (hcl_oop_process_scheduler_t) hcl_moveoop (hcl, (hcl_oop_t)hcl->processor); hcl->processor = (hcl_oop_process_scheduler_t) hcl_moveoop (hcl, (hcl_oop_t)hcl->processor);
hcl->nil_process = (hcl_oop_process_t) hcl_moveoop (hcl, (hcl_oop_t)hcl->nil_process); hcl->nil_process = (hcl_oop_process_t) hcl_moveoop (hcl, (hcl_oop_t)hcl->nil_process);
@ -377,7 +377,7 @@ void hcl_gc (hcl_t* hcl)
compact_symbol_table (hcl, old_nil); compact_symbol_table (hcl, old_nil);
/* move the symbol table itself */ /* move the symbol table itself */
hcl->symtab = (hcl_oop_set_t)hcl_moveoop (hcl, (hcl_oop_t)hcl->symtab); hcl->symtab = (hcl_oop_dic_t)hcl_moveoop (hcl, (hcl_oop_t)hcl->symtab);
/* scan the new heap again from the end position of /* scan the new heap again from the end position of
* the previous scan to move referenced objects by * the previous scan to move referenced objects by
@ -488,13 +488,13 @@ int hcl_ignite (hcl_t* hcl)
if (!hcl->symtab) if (!hcl->symtab)
{ {
hcl->symtab = (hcl_oop_set_t)hcl_makeset (hcl, hcl->option.dfl_symtab_size); hcl->symtab = (hcl_oop_dic_t)hcl_makedic (hcl, hcl->option.dfl_symtab_size);
if (!hcl->symtab) return -1; if (!hcl->symtab) return -1;
} }
if (!hcl->sysdic) if (!hcl->sysdic)
{ {
hcl->sysdic = (hcl_oop_set_t)hcl_makeset (hcl, hcl->option.dfl_sysdic_size); hcl->sysdic = (hcl_oop_dic_t)hcl_makedic (hcl, hcl->option.dfl_sysdic_size);
if (!hcl->sysdic) return -1; if (!hcl->sysdic) return -1;
} }

26
lib/hcl-prv.h
View File

@ -704,8 +704,8 @@ enum hcl_bcode_t
BCODE_SEND_MESSAGE_X = 0xF0, /* 240 ## */ BCODE_SEND_MESSAGE_X = 0xF0, /* 240 ## */
/* UNUSED 241 */ /* UNUSED 241 */
HCL_CODE_MAKE_DICTIONARY = 0xF2, /* 242 */ HCL_CODE_MAKE_DIC = 0xF2, /* 242 */
HCL_CODE_POP_INTO_DICTIONARY = 0xF3, /* 243 */ HCL_CODE_POP_INTO_DIC = 0xF3, /* 243 */
BCODE_SEND_MESSAGE_TO_SUPER_X = 0xF4, /* 244 ## */ BCODE_SEND_MESSAGE_TO_SUPER_X = 0xF4, /* 244 ## */
/* -------------------------------------- */ /* -------------------------------------- */
@ -885,35 +885,19 @@ hcl_oop_cons_t hcl_getatsysdic (
hcl_oop_t key hcl_oop_t key
); );
hcl_oop_cons_t hcl_lookupsysdic (
hcl_t* hcl,
const hcl_oocs_t* name
);
hcl_oop_cons_t hcl_putatdic ( hcl_oop_cons_t hcl_putatdic (
hcl_t* hcl, hcl_t* hcl,
hcl_oop_set_t dic, hcl_oop_dic_t dic,
hcl_oop_t key, hcl_oop_t key,
hcl_oop_t value hcl_oop_t value
); );
hcl_oop_cons_t hcl_getatdic ( hcl_oop_cons_t hcl_getatdic (
hcl_t* hcl, hcl_t* hcl,
hcl_oop_set_t dic, hcl_oop_dic_t dic,
hcl_oop_t key hcl_oop_t key
); );
hcl_oop_cons_t hcl_lookupdic (
hcl_t* hcl,
hcl_oop_set_t dic,
const hcl_oocs_t* name
);
hcl_oop_set_t hcl_makedic (
hcl_t* hcl,
hcl_oow_t size
);
/* ========================================================================= */ /* ========================================================================= */
/* proc.c */ /* proc.c */
/* ========================================================================= */ /* ========================================================================= */
@ -1169,7 +1153,7 @@ int hcl_outfmtobj (
/* debug.c */ /* debug.c */
/* ========================================================================= */ /* ========================================================================= */
void dump_symbol_table (hcl_t* hcl); void dump_symbol_table (hcl_t* hcl);
void dump_dictionary (hcl_t* hcl, hcl_oop_set_t dic, const char* title); void dump_dictionary (hcl_t* hcl, hcl_oop_dic_t dic, const char* title);
#if defined(__cplusplus) #if defined(__cplusplus)
} }

14
lib/hcl.h
View File

@ -493,7 +493,7 @@ struct hcl_trailer_t
#define HCL_SET_NAMED_INSTVARS 2 #define HCL_SET_NAMED_INSTVARS 2
typedef struct hcl_set_t hcl_set_t; typedef struct hcl_set_t hcl_set_t;
typedef struct hcl_set_t* hcl_oop_set_t; typedef struct hcl_set_t* hcl_oop_dic_t;
struct hcl_set_t struct hcl_set_t
{ {
HCL_OBJ_HEADER; HCL_OBJ_HEADER;
@ -526,7 +526,7 @@ struct hcl_class_t
/* [0] - instance methods, MethodDictionary /* [0] - instance methods, MethodDictionary
* [1] - class methods, MethodDictionary */ * [1] - class methods, MethodDictionary */
hcl_oop_set_t mthdic[2]; hcl_oop_dic_t mthdic[2];
/* indexed part afterwards */ /* indexed part afterwards */
hcl_oop_t slot[1]; /* class instance variables and class variables. */ hcl_oop_t slot[1]; /* class instance variables and class variables. */
@ -954,8 +954,8 @@ struct hcl_t
hcl_oop_t _large_negative_integer; /* LargeNegativeInteger */ hcl_oop_t _large_negative_integer; /* LargeNegativeInteger */
/* == NEVER CHANGE THE ORDER OF FIELDS ABOVE == */ /* == NEVER CHANGE THE ORDER OF FIELDS ABOVE == */
hcl_oop_set_t symtab; /* system-wide symbol table. */ hcl_oop_dic_t symtab; /* system-wide symbol table. */
hcl_oop_set_t sysdic; /* system dictionary. */ hcl_oop_dic_t sysdic; /* system dictionary. */
hcl_oop_process_scheduler_t processor; /* instance of ProcessScheduler */ hcl_oop_process_scheduler_t processor; /* instance of ProcessScheduler */
hcl_oop_process_t nil_process; /* instance of Process */ hcl_oop_process_t nil_process; /* instance of Process */
@ -1309,7 +1309,7 @@ enum
HCL_BRAND_SYMBOL_ARRAY, /* special. internal use only */ HCL_BRAND_SYMBOL_ARRAY, /* special. internal use only */
HCL_BRAND_SYMBOL, HCL_BRAND_SYMBOL,
HCL_BRAND_STRING, HCL_BRAND_STRING,
HCL_BRAND_SET, HCL_BRAND_DIC,
HCL_BRAND_CFRAME,/* compiler frame */ HCL_BRAND_CFRAME,/* compiler frame */
HCL_BRAND_PRIM, HCL_BRAND_PRIM,
@ -1343,7 +1343,7 @@ enum
HCL_CONCODE_XLIST = 0, /* () - executable list */ HCL_CONCODE_XLIST = 0, /* () - executable list */
HCL_CONCODE_ARRAY, /* #() */ HCL_CONCODE_ARRAY, /* #() */
HCL_CONCODE_BYTEARRAY, /* #[] */ HCL_CONCODE_BYTEARRAY, /* #[] */
HCL_CONCODE_DICTIONARY, /* #{} */ HCL_CONCODE_DIC, /* #{} */
HCL_CONCODE_QLIST /* '() - quoted list, data list */ HCL_CONCODE_QLIST /* '() - quoted list, data list */
}; };
@ -1706,7 +1706,7 @@ HCL_EXPORT hcl_oop_t hcl_makestring (
hcl_oow_t len hcl_oow_t len
); );
HCL_EXPORT hcl_oop_t hcl_makeset ( HCL_EXPORT hcl_oop_t hcl_makedic (
hcl_t* hcl, hcl_t* hcl,
hcl_oow_t inisize /* initial bucket size */ hcl_oow_t inisize /* initial bucket size */
); );

20
lib/obj.c
View File

@ -411,27 +411,7 @@ hcl_oop_t hcl_makestring (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len)
return hcl_alloccharobj (hcl, HCL_BRAND_STRING, ptr, len); return hcl_alloccharobj (hcl, HCL_BRAND_STRING, ptr, len);
} }
hcl_oop_t hcl_makeset (hcl_t* hcl, hcl_oow_t inisize)
{
hcl_oop_set_t obj;
obj = (hcl_oop_set_t)hcl_allocoopobj (hcl, HCL_BRAND_SET, 2);
if (obj)
{
hcl_oop_oop_t bucket;
obj->tally = HCL_SMOOI_TO_OOP(0);
hcl_pushtmp (hcl, (hcl_oop_t*)&obj);
bucket = (hcl_oop_oop_t)hcl_makearray (hcl, inisize);
hcl_poptmp (hcl);
if (!bucket) obj = HCL_NULL;
else obj->bucket = bucket;
}
return (hcl_oop_t)obj;
}

146
lib/print.c
View File

@ -30,16 +30,23 @@
#define PRINT_STACK_ALIGN 128 #define PRINT_STACK_ALIGN 128
#define PRINT_STACK_ARRAY_END 0 enum
#define PRINT_STACK_CONS 1 {
#define PRINT_STACK_ARRAY 2 PRINT_STACK_CONS,
PRINT_STACK_ARRAY,
PRINT_STACK_ARRAY_END,
PRINT_STACK_DIC,
PRINT_STACK_DIC_END
};
typedef struct print_stack_t print_stack_t; typedef struct print_stack_t print_stack_t;
struct print_stack_t struct print_stack_t
{ {
int type; int type;
hcl_oop_t obj; hcl_oop_t obj;
hcl_oop_t obj2;
hcl_oow_t idx; hcl_oow_t idx;
hcl_oow_t idx2;
}; };
static HCL_INLINE int push (hcl_t* hcl, print_stack_t* info) static HCL_INLINE int push (hcl_t* hcl, print_stack_t* info)
@ -262,7 +269,7 @@ next:
"(", /*HCL_CONCODE_XLIST */ "(", /*HCL_CONCODE_XLIST */
"#(", /*HCL_CONCODE_ARRAY */ "#(", /*HCL_CONCODE_ARRAY */
"#[", /*HCL_CONCODE_BYTEARRAY */ "#[", /*HCL_CONCODE_BYTEARRAY */
"#{", /*HCL_CONCODE_DICTIONARY */ "#{", /*HCL_CONCODE_DIC */
"'(" /*HCL_CONCODE_QLIST */ "'(" /*HCL_CONCODE_QLIST */
}; };
@ -271,7 +278,7 @@ next:
")", /*HCL_CONCODE_XLIST */ ")", /*HCL_CONCODE_XLIST */
")", /*HCL_CONCODE_ARRAY */ ")", /*HCL_CONCODE_ARRAY */
"]", /*HCL_CONCODE_BYTEARRAY */ "]", /*HCL_CONCODE_BYTEARRAY */
"}", /*HCL_CONCODE_DICTIONARY */ "}", /*HCL_CONCODE_DIC */
")" /*HCL_CONCODE_QLIST */ ")" /*HCL_CONCODE_QLIST */
}; };
@ -340,25 +347,11 @@ next:
{ {
hcl_oow_t arridx; hcl_oow_t arridx;
if (brand == HCL_BRAND_ARRAY) if (outbfmt(hcl, mask, "#(") <= -1) return -1;
{
if (outbfmt(hcl, mask, "#(") <= -1) return -1;
}
else
{
if (outbfmt(hcl, mask, "|") <= -1) return -1;
}
if (HCL_OBJ_GET_SIZE(obj) <= 0) if (HCL_OBJ_GET_SIZE(obj) <= 0)
{ {
if (brand == HCL_BRAND_ARRAY) if (outbfmt(hcl, mask, ")") <= -1) return -1;
{
if (outbfmt(hcl, mask, ")") <= -1) return -1;
}
else
{
if (outbfmt(hcl, mask, "|") <= -1) return -1;
}
break; break;
} }
arridx = 0; arridx = 0;
@ -417,6 +410,106 @@ next:
break; break;
} }
case HCL_BRAND_DIC:
{
hcl_oow_t bucidx, bucsize, buctally;
hcl_oop_dic_t dic;
if (outbfmt(hcl, mask, "#{") <= -1) return -1;
dic = (hcl_oop_dic_t)obj;
HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(dic->tally));
if (HCL_OOP_TO_SMOOI(dic->tally) <= 0)
{
if (outbfmt(hcl, mask, "}") <= -1) return -1;
break;
}
bucidx = 0;
bucsize = HCL_OBJ_GET_SIZE(dic->bucket);
buctally = 0;
ps.type = PRINT_STACK_DIC;
ps.obj2 = (hcl_oop_t)dic;
do
{
int x;
if ((buctally & 1) == 0)
{
while (bucidx < bucsize)
{
/* skip an unoccupied slot in the bucket array */
obj = dic->bucket->slot[bucidx];
if (!HCL_IS_NIL(hcl,obj)) break;
bucidx++;
}
if (bucidx >= bucsize)
{
/* done. scanned the entire bucket */
if (outbfmt(hcl, mask, "}") <= -1) return -1;
break;
}
ps.idx = bucidx; /* no increment yet */
HCL_ASSERT (hcl, ps.idx < bucsize);
HCL_ASSERT (hcl, ps.type == PRINT_STACK_DIC);
ps.obj = dic->bucket->slot[ps.idx];
ps.idx2 = buctally + 1;
x = push (hcl, &ps);
if (x <= -1) return -1;
HCL_ASSERT (hcl, HCL_IS_CONS(hcl,obj));
obj = HCL_CONS_CAR(obj);
}
else
{
/* Push what to print next on to the stack */
ps.idx = bucidx + 1;
if (ps.idx >= bucsize)
{
ps.type = PRINT_STACK_DIC_END;
}
else
{
HCL_ASSERT (hcl, ps.type == PRINT_STACK_DIC);
ps.obj = dic->bucket->slot[ps.idx];
}
ps.idx2 = buctally + 1;
x = push (hcl, &ps);
if (x <= -1) return -1;
HCL_ASSERT (hcl, HCL_IS_CONS(hcl,obj));
obj = HCL_CONS_CDR(obj);
}
if (buctally > 0)
{
if (outbfmt(hcl, mask, " ") <= -1) return -1;
}
/* Jump to the 'next' label so that the object
* pointed to by 'obj' is printed. Once it
* ends, a jump back to the 'resume' label
* is made at the end of this function. */
goto next;
resume_dic:
HCL_ASSERT (hcl, ps.type == PRINT_STACK_DIC);
bucidx = ps.idx;
buctally = ps.idx2;
obj = ps.obj;
dic = (hcl_oop_dic_t)ps.obj2;
bucsize = HCL_OBJ_GET_SIZE(dic->bucket);
}
while (1);
break;
}
case HCL_BRAND_SYMBOL_ARRAY: case HCL_BRAND_SYMBOL_ARRAY:
{ {
hcl_oow_t i; hcl_oow_t i;
@ -433,10 +526,6 @@ next:
break; break;
} }
case HCL_BRAND_SET:
word_index = WORD_SET;
goto print_word;
case HCL_BRAND_CFRAME: case HCL_BRAND_CFRAME:
word_index = WORD_CFRAME; word_index = WORD_CFRAME;
goto print_word; goto print_word;
@ -490,6 +579,13 @@ done:
if (outbfmt(hcl, mask, ")") <= -1) return -1; if (outbfmt(hcl, mask, ")") <= -1) return -1;
break; break;
case PRINT_STACK_DIC:
goto resume_dic;
case PRINT_STACK_DIC_END:
if (outbfmt(hcl, mask, "}") <= -1) return -1;
break;
default: default:
HCL_DEBUG3 (hcl, "Internal error - unknown print stack type %d at %s:%d\n", (int)ps.type, __FILE__, __LINE__); HCL_DEBUG3 (hcl, "Internal error - unknown print stack type %d at %s:%d\n", (int)ps.type, __FILE__, __LINE__);
hcl_seterrbfmt (hcl, HCL_EINTERN, "unknown print stack type %d", (int)ps.type); hcl_seterrbfmt (hcl, HCL_EINTERN, "unknown print stack type %d", (int)ps.type);

6
lib/read.c
View File

@ -1348,7 +1348,7 @@ done:
return (hcl_oop_t)hcl_makearray(hcl, 0); return (hcl_oop_t)hcl_makearray(hcl, 0);
case HCL_CONCODE_BYTEARRAY: case HCL_CONCODE_BYTEARRAY:
return (hcl_oop_t)hcl_makebytearray(hcl, HCL_NULL, 0); return (hcl_oop_t)hcl_makebytearray(hcl, HCL_NULL, 0);
case HCL_CONCODE_DICTIONARY: case HCL_CONCODE_DIC:
return (hcl_oop_t)hcl_makedic(hcl, 100); /* TODO: default dictionary size for empty definition? */ return (hcl_oop_t)hcl_makedic(hcl, 100); /* TODO: default dictionary size for empty definition? */
} }
} }
@ -1662,7 +1662,7 @@ static int read_object (hcl_t* hcl)
goto start_list; goto start_list;
case HCL_IOTOK_DPAREN: case HCL_IOTOK_DPAREN:
flagv = 0; flagv = 0;
LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_DICTIONARY); LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_DIC);
goto start_list; goto start_list;
case HCL_IOTOK_QPAREN: case HCL_IOTOK_QPAREN:
flagv = 0; flagv = 0;
@ -1716,7 +1716,7 @@ static int read_object (hcl_t* hcl)
{ HCL_IOTOK_RPAREN, HCL_SYNERR_RPAREN }, /* XLIST */ { HCL_IOTOK_RPAREN, HCL_SYNERR_RPAREN }, /* XLIST */
{ HCL_IOTOK_RPAREN, HCL_SYNERR_RPAREN }, /* ARRAY */ { HCL_IOTOK_RPAREN, HCL_SYNERR_RPAREN }, /* ARRAY */
{ HCL_IOTOK_RBRACK, HCL_SYNERR_RBRACK }, /* BYTEARRAY */ { HCL_IOTOK_RBRACK, HCL_SYNERR_RBRACK }, /* BYTEARRAY */
{ HCL_IOTOK_RBRACE, HCL_SYNERR_RBRACE }, /* DICTIONARY */ { HCL_IOTOK_RBRACE, HCL_SYNERR_RBRACE }, /* DIC */
{ HCL_IOTOK_RPAREN, HCL_SYNERR_RPAREN } /* QLIST */ { HCL_IOTOK_RPAREN, HCL_SYNERR_RPAREN } /* QLIST */
}; };