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_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_POP_INTO_ARRAY:
bc = cmd;
@ -616,7 +616,7 @@ enum
COP_COMPILE_IF_OBJECT_LIST_TAIL,
COP_COMPILE_ARRAY_LIST,
COP_COMPILE_DICTIONARY_LIST,
COP_COMPILE_DIC_LIST,
COP_SUBCOMPILE_ELIF,
COP_SUBCOMPILE_ELSE,
@ -624,9 +624,9 @@ enum
COP_EMIT_CALL,
COP_EMIT_MAKE_ARRAY,
COP_EMIT_MAKE_DICTIONARY,
COP_EMIT_MAKE_DIC,
COP_EMIT_POP_INTO_ARRAY,
COP_EMIT_POP_INTO_DICTIONARY,
COP_EMIT_POP_INTO_DIC,
COP_EMIT_LAMBDA,
COP_EMIT_POP_STACKTOP,
@ -1132,14 +1132,13 @@ static int compile_cons_array_expression (hcl_t* hcl, hcl_oop_t obj)
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_cframe_t* cf;
printf ("XXXXXXXXXXXXXx\n");
SWITCH_TOP_CFRAME (hcl, COP_EMIT_MAKE_DICTIONARY, HCL_SMOOI_TO_OOP(0));
SWITCH_TOP_CFRAME (hcl, COP_EMIT_MAKE_DIC, HCL_SMOOI_TO_OOP(0));
nargs = hcl_countcons(hcl, obj);
if (nargs > MAX_CODE_PARAM)
@ -1150,11 +1149,11 @@ printf ("XXXXXXXXXXXXXx\n");
}
/* 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);
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);
return 0;
@ -1412,8 +1411,8 @@ static int compile_object (hcl_t* hcl)
if (compile_cons_bytearray_expression (hcl, cf->operand) <= -1) return -1;
break;
*/
case HCL_CONCODE_DICTIONARY:
if (compile_cons_dictionary_expression(hcl, cf->operand) <= -1) return -1;
case HCL_CONCODE_DIC:
if (compile_cons_dic_expression(hcl, cf->operand) <= -1) return -1;
break;
/* TODO: QLIST? */
@ -1598,13 +1597,13 @@ static int compile_array_list (hcl_t* hcl)
return 0;
}
static int compile_dictionary_list (hcl_t* hcl)
static int compile_dic_list (hcl_t* hcl)
{
hcl_cframe_t* cf;
hcl_oop_t coperand;
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;
@ -1641,10 +1640,10 @@ static int compile_dictionary_list (hcl_t* hcl)
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);
}
@ -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;
int n;
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));
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);
return n;
@ -2008,15 +2007,15 @@ static HCL_INLINE int emit_pop_into_array (hcl_t* hcl)
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;
int n;
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);
return n;
@ -2178,8 +2177,8 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
if (compile_array_list(hcl) <= -1) goto oops;
break;
case COP_COMPILE_DICTIONARY_LIST:
if (compile_dictionary_list(hcl) <= -1) goto oops;
case COP_COMPILE_DIC_LIST:
if (compile_dic_list(hcl) <= -1) goto oops;
break;
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;
break;
case COP_EMIT_MAKE_DICTIONARY:
if (emit_make_dictionary(hcl) <= -1) goto oops;
case COP_EMIT_MAKE_DIC:
if (emit_make_dic(hcl) <= -1) goto oops;
break;
case COP_EMIT_POP_INTO_ARRAY:
if (emit_pop_into_array(hcl) <= -1) goto oops;
break;
case COP_EMIT_POP_INTO_DICTIONARY:
if (emit_pop_into_dictionary(hcl) <= -1) goto oops;
case COP_EMIT_POP_INTO_DIC:
if (emit_pop_into_dic(hcl) <= -1) goto oops;
break;
case COP_EMIT_LAMBDA:

2
lib/debug.c
View File

@ -47,7 +47,7 @@ void hcl_dumpsymtab (hcl_t* hcl)
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_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);
break;
case HCL_CODE_MAKE_DICTIONARY:
case HCL_CODE_MAKE_DIC:
FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "make_dictionary %zu", b1);
LOG_INST_1 (hcl, "make_dic %zu", b1);
break;
case HCL_CODE_POP_INTO_DICTIONARY:
LOG_INST_0 (hcl, "pop_into_dictionary");
case HCL_CODE_POP_INTO_DIC:
LOG_INST_0 (hcl, "pop_into_dic");
break;
/* -------------------------------------------------------- */

118
lib/dic.c
View File

@ -26,6 +26,8 @@
#include "hcl-prv.h"
/*#define SYMBOL_ONLY_KEY */
static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc)
{
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];
if ((hcl_oop_t)ass != hcl->_nil)
{
#if defined(SYMBOL_ONLY_KEY)
HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass));
key = (hcl_oop_char_t)ass->car;
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
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;
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;
}
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_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.
* 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)) % 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 */
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));
@ -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 */
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);
}
@ -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.
* 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;
}
@ -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;
#if defined(SYMBOL_ONLY_KEY)
/* 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, 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)
index = (index + 1) % HCL_OBJ_GET_SIZE(dic->bucket);
@ -189,75 +224,56 @@ oops:
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)
{
#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);
}
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);
}
hcl_oop_cons_t hcl_lookupsysdic (hcl_t* hcl, const hcl_oocs_t* name)
{
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)
hcl_oop_cons_t hcl_putatdic (hcl_t* hcl, hcl_oop_dic_t dic, 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, 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));
#endif
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;
obj = (hcl_oop_dic_t)hcl_allocoopobj (hcl, HCL_BRAND_DIC, 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;
}
hcl_oop_set_t hcl_makedic (hcl_t* hcl, hcl_oow_t size)
{
return (hcl_oop_set_t)hcl_makeset (hcl, size);
return (hcl_oop_t)obj;
}

11
lib/exec.c
View File

@ -1842,30 +1842,29 @@ static int execute (hcl_t* hcl)
break;
}
case HCL_CODE_MAKE_DICTIONARY:
case HCL_CODE_MAKE_DIC:
{
hcl_oop_t t;
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);
if (!t) return -1;
HCL_STACK_PUSH (hcl, t);
break;
}
case HCL_CODE_POP_INTO_DICTIONARY:
case HCL_CODE_POP_INTO_DIC:
{
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 */
HCL_STACK_POP (hcl);
t2 = HCL_STACK_GETTOP(hcl); /* key */
HCL_STACK_POP (hcl);
t3 = HCL_STACK_GETTOP(hcl); /* dictionary */
/* TODO: generic dictioanry??? */
if (!hcl_putatdic (hcl, (hcl_oop_set_t)t3, t2, t1)) return -1;
if (!hcl_putatdic (hcl, (hcl_oop_dic_t)t3, t2, t1)) return -1;
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_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->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);
/* 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
* the previous scan to move referenced objects by
@ -488,13 +488,13 @@ int hcl_ignite (hcl_t* hcl)
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->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;
}

26
lib/hcl-prv.h
View File

@ -704,8 +704,8 @@ enum hcl_bcode_t
BCODE_SEND_MESSAGE_X = 0xF0, /* 240 ## */
/* UNUSED 241 */
HCL_CODE_MAKE_DICTIONARY = 0xF2, /* 242 */
HCL_CODE_POP_INTO_DICTIONARY = 0xF3, /* 243 */
HCL_CODE_MAKE_DIC = 0xF2, /* 242 */
HCL_CODE_POP_INTO_DIC = 0xF3, /* 243 */
BCODE_SEND_MESSAGE_TO_SUPER_X = 0xF4, /* 244 ## */
/* -------------------------------------- */
@ -885,35 +885,19 @@ hcl_oop_cons_t hcl_getatsysdic (
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_t* hcl,
hcl_oop_set_t dic,
hcl_oop_dic_t dic,
hcl_oop_t key,
hcl_oop_t value
);
hcl_oop_cons_t hcl_getatdic (
hcl_t* hcl,
hcl_oop_set_t dic,
hcl_oop_dic_t dic,
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 */
/* ========================================================================= */
@ -1169,7 +1153,7 @@ int hcl_outfmtobj (
/* debug.c */
/* ========================================================================= */
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)
}

14
lib/hcl.h
View File

@ -493,7 +493,7 @@ struct hcl_trailer_t
#define HCL_SET_NAMED_INSTVARS 2
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
{
HCL_OBJ_HEADER;
@ -526,7 +526,7 @@ struct hcl_class_t
/* [0] - instance methods, MethodDictionary
* [1] - class methods, MethodDictionary */
hcl_oop_set_t mthdic[2];
hcl_oop_dic_t mthdic[2];
/* indexed part afterwards */
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 */
/* == NEVER CHANGE THE ORDER OF FIELDS ABOVE == */
hcl_oop_set_t symtab; /* system-wide symbol table. */
hcl_oop_set_t sysdic; /* system dictionary. */
hcl_oop_dic_t symtab; /* system-wide symbol table. */
hcl_oop_dic_t sysdic; /* system dictionary. */
hcl_oop_process_scheduler_t processor; /* instance of ProcessScheduler */
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,
HCL_BRAND_STRING,
HCL_BRAND_SET,
HCL_BRAND_DIC,
HCL_BRAND_CFRAME,/* compiler frame */
HCL_BRAND_PRIM,
@ -1343,7 +1343,7 @@ enum
HCL_CONCODE_XLIST = 0, /* () - executable list */
HCL_CONCODE_ARRAY, /* #() */
HCL_CONCODE_BYTEARRAY, /* #[] */
HCL_CONCODE_DICTIONARY, /* #{} */
HCL_CONCODE_DIC, /* #{} */
HCL_CONCODE_QLIST /* '() - quoted list, data list */
};
@ -1706,7 +1706,7 @@ HCL_EXPORT hcl_oop_t hcl_makestring (
hcl_oow_t len
);
HCL_EXPORT hcl_oop_t hcl_makeset (
HCL_EXPORT hcl_oop_t hcl_makedic (
hcl_t* hcl,
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);
}
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;
}

142
lib/print.c
View File

@ -30,16 +30,23 @@
#define PRINT_STACK_ALIGN 128
#define PRINT_STACK_ARRAY_END 0
#define PRINT_STACK_CONS 1
#define PRINT_STACK_ARRAY 2
enum
{
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;
struct print_stack_t
{
int type;
hcl_oop_t obj;
hcl_oop_t obj2;
hcl_oow_t idx;
hcl_oow_t idx2;
};
static HCL_INLINE int push (hcl_t* hcl, print_stack_t* info)
@ -262,7 +269,7 @@ next:
"(", /*HCL_CONCODE_XLIST */
"#(", /*HCL_CONCODE_ARRAY */
"#[", /*HCL_CONCODE_BYTEARRAY */
"#{", /*HCL_CONCODE_DICTIONARY */
"#{", /*HCL_CONCODE_DIC */
"'(" /*HCL_CONCODE_QLIST */
};
@ -271,7 +278,7 @@ next:
")", /*HCL_CONCODE_XLIST */
")", /*HCL_CONCODE_ARRAY */
"]", /*HCL_CONCODE_BYTEARRAY */
"}", /*HCL_CONCODE_DICTIONARY */
"}", /*HCL_CONCODE_DIC */
")" /*HCL_CONCODE_QLIST */
};
@ -340,25 +347,11 @@ next:
{
hcl_oow_t arridx;
if (brand == HCL_BRAND_ARRAY)
{
if (outbfmt(hcl, mask, "#(") <= -1) return -1;
}
else
{
if (outbfmt(hcl, mask, "|") <= -1) return -1;
}
if (HCL_OBJ_GET_SIZE(obj) <= 0)
{
if (brand == HCL_BRAND_ARRAY)
{
if (outbfmt(hcl, mask, ")") <= -1) return -1;
}
else
{
if (outbfmt(hcl, mask, "|") <= -1) return -1;
}
break;
}
arridx = 0;
@ -417,6 +410,106 @@ next:
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:
{
hcl_oow_t i;
@ -433,10 +526,6 @@ next:
break;
}
case HCL_BRAND_SET:
word_index = WORD_SET;
goto print_word;
case HCL_BRAND_CFRAME:
word_index = WORD_CFRAME;
goto print_word;
@ -490,6 +579,13 @@ done:
if (outbfmt(hcl, mask, ")") <= -1) return -1;
break;
case PRINT_STACK_DIC:
goto resume_dic;
case PRINT_STACK_DIC_END:
if (outbfmt(hcl, mask, "}") <= -1) return -1;
break;
default:
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);

6
lib/read.c
View File

@ -1348,7 +1348,7 @@ done:
return (hcl_oop_t)hcl_makearray(hcl, 0);
case HCL_CONCODE_BYTEARRAY:
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? */
}
}
@ -1662,7 +1662,7 @@ static int read_object (hcl_t* hcl)
goto start_list;
case HCL_IOTOK_DPAREN:
flagv = 0;
LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_DICTIONARY);
LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_DIC);
goto start_list;
case HCL_IOTOK_QPAREN:
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 }, /* ARRAY */
{ 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 */
};