From 979ba9776995aa5883484a55c56d705a2421faf8 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Wed, 7 Feb 2018 07:35:30 +0000 Subject: [PATCH] enhanced the compiler to handle array enclosed in #(). added partial code to handle dictionary enclosed in #{} --- lib/comp.c | 323 ++++++++++++++++++++++++++++++++++++++++++++++---- lib/decode.c | 21 ++++ lib/dic.c | 18 +-- lib/gc.c | 2 + lib/hcl-prv.h | 5 + lib/hcl.h | 23 +++- lib/main.c | 3 +- lib/obj.c | 170 ++++++++++++++++++++++++++ lib/read.c | 87 +++++++++----- 9 files changed, 581 insertions(+), 71 deletions(-) diff --git a/lib/comp.c b/lib/comp.c index 3e5bbf6..367eab5 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -234,7 +234,6 @@ static int emit_single_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1 goto write_long2; } - case HCL_CODE_PUSH_OBJECT_0: case HCL_CODE_STORE_INTO_OBJECT_0: case BCODE_POP_INTO_OBJECT_0: @@ -263,6 +262,10 @@ static int emit_single_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1 case HCL_CODE_PUSH_INTLIT: 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_ARRAY: + case HCL_CODE_POP_INTO_ARRAY: bc = cmd; goto write_long; } @@ -612,10 +615,19 @@ enum COP_COMPILE_OBJECT_LIST_TAIL, COP_COMPILE_IF_OBJECT_LIST_TAIL, + COP_COMPILE_ARRAY_LIST, + COP_COMPILE_DICTIONARY_LIST, + COP_SUBCOMPILE_ELIF, COP_SUBCOMPILE_ELSE, COP_EMIT_CALL, + + COP_EMIT_MAKE_ARRAY, + COP_EMIT_MAKE_DICTIONARY, + COP_EMIT_POP_INTO_ARRAY, + COP_EMIT_POP_INTO_DICTIONARY, + COP_EMIT_LAMBDA, COP_EMIT_POP_STACKTOP, COP_EMIT_RETURN, @@ -1089,11 +1101,69 @@ static int compile_while (hcl_t* hcl, hcl_oop_t src, int next_cop) } /* ========================================================================= */ +static int compile_cons_array_expression (hcl_t* hcl, hcl_oop_t obj) +{ + /* #[ ] */ + hcl_ooi_t nargs; + hcl_cframe_t* cf; -static int compile_cons_expression (hcl_t* hcl, hcl_oop_t obj) + /* NOTE: cframe management functions don't use the object memory. + * many operations can be performed without taking GC into account */ + SWITCH_TOP_CFRAME (hcl, COP_EMIT_MAKE_ARRAY, HCL_SMOOI_TO_OOP(0)); + + nargs = hcl_countcons(hcl, obj); + if (nargs > MAX_CODE_PARAM) + { + /* TODO: change to syntax error */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_NULL, HCL_NULL, "too many(%zd) elements into array - %O", nargs, obj); + return -1; + } + + /* redundant cdr check is performed inside compile_object_list() */ + PUSH_SUBCFRAME (hcl, COP_COMPILE_ARRAY_LIST, obj); + cf = GET_SUBCFRAME(hcl); + cf->u.array_list.index = 0; + + /* patch the argument count in the operand field of the COP_MAKE_ARRAY frame */ + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_ARRAY); + cf->operand = HCL_SMOOI_TO_OOP(nargs); + + return 0; +} + +static int compile_cons_dictionary_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)); + + nargs = hcl_countcons(hcl, obj); + if (nargs > MAX_CODE_PARAM) + { + /* TODO: change to syntax error */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_NULL, HCL_NULL, "too many(%zd) elements into dictionary - %O", nargs, obj); + return -1; + } + + /* redundant cdr check is performed inside compile_object_list() */ + PUSH_SUBCFRAME (hcl, COP_COMPILE_DICTIONARY_LIST, obj); + + /* patch the argument count in the operand field of the COP_MAKE_DICTIONARY frame */ + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_DICTIONARY); + cf->operand = HCL_SMOOI_TO_OOP(nargs); + + return 0; +} + +static int compile_cons_xlist_expression (hcl_t* hcl, hcl_oop_t obj) { hcl_oop_t car; - int syncode; + int syncode; /* syntax code of the first element */ /* a valid function call * (function-name argument-list) @@ -1103,7 +1173,7 @@ static int compile_cons_expression (hcl_t* hcl, hcl_oop_t obj) * if the name is another function call, i can't know if the * function name will be valid at the compile time. */ - HCL_ASSERT (hcl, HCL_IS_CONS(hcl, obj)); + HCL_ASSERT (hcl, HCL_IS_CONS_XLIST(hcl, obj)); car = HCL_CONS_CAR(obj); if (HCL_IS_SYMBOL(hcl,car) && (syncode = HCL_OBJ_GET_FLAGS_SYNCODE(car))) @@ -1112,7 +1182,7 @@ static int compile_cons_expression (hcl_t* hcl, hcl_oop_t obj) { case HCL_SYNCODE_BREAK: /* break */ - if (compile_break (hcl, obj) <= -1) return -1; + if (compile_break(hcl, obj) <= -1) return -1; break; case HCL_SYNCODE_DEFUN: @@ -1121,15 +1191,16 @@ HCL_DEBUG0 (hcl, "DEFUN NOT IMPLEMENTED...\n"); break; case HCL_SYNCODE_DO: -HCL_DEBUG0 (hcl, "DO NOT IMPLEMENTED...\n"); +HCL_DEBUG0 (hcl, "DO NOT IMPLEMENTED...\n"); /* TODO: not implemented yet */ break; case HCL_SYNCODE_ELSE: hcl_setsynerrbfmt (hcl, HCL_SYNERR_ELSE, HCL_NULL, HCL_NULL, "else without if - %O", obj); /* error location */ return -1; + case HCL_SYNCODE_ELIF: - hcl_setsynerrbfmt(hcl, HCL_SYNERR_ELIF, HCL_NULL, HCL_NULL, "elif without if - %O", obj); /* error location */ + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ELIF, HCL_NULL, HCL_NULL, "elif without if - %O", obj); /* error location */ return -1; case HCL_SYNCODE_IF: @@ -1167,7 +1238,7 @@ HCL_DEBUG0 (hcl, "DO NOT IMPLEMENTED...\n"); return -1; } } - else if (HCL_IS_SYMBOL(hcl,car) || HCL_IS_CONS(hcl,car)) + else if (HCL_IS_SYMBOL(hcl,car) || HCL_IS_CONS_XLIST(hcl,car)) { /* normal function call * ( ...) */ @@ -1179,19 +1250,16 @@ HCL_DEBUG0 (hcl, "DO NOT IMPLEMENTED...\n"); /* NOTE: cframe management functions don't use the object memory. * many operations can be performed without taking GC into account */ - oldtop = GET_TOP_CFRAME_INDEX(hcl); + /* store the position of COP_EMIT_CALL to be produced with + * SWITCH_TOP_CFRAM() in oldtop for argument count patching + * further down */ + oldtop = GET_TOP_CFRAME_INDEX(hcl); HCL_ASSERT (hcl, oldtop >= 0); SWITCH_TOP_CFRAME (hcl, COP_EMIT_CALL, HCL_SMOOI_TO_OOP(0)); /* compile */ PUSH_CFRAME (hcl, COP_COMPILE_OBJECT, car); -/* TODO: do pre-filtering. if car is a literal, it's not a valid function call - this can also be check in the reader. - * if it's a symbol and it evaluates to a literal, it can only be caught in the runtime -* this check along with the .cdr check, can be done in the reader if i create a special flag (e.g. QUOTED) applicable to CONS. -* what happens if someone likes to manipulate the list as the list is not a single object type unlike array??? -* (define (x y) (10 20 30)) -*/ /* compile ... etc */ cdr = HCL_CONS_CDR(obj); @@ -1333,11 +1401,33 @@ static int compile_object (hcl_t* hcl) goto done; case HCL_BRAND_CONS: - if (compile_cons_expression (hcl, cf->operand) <= -1) return -1; + { + switch (HCL_OBJ_GET_FLAGS_SYNCODE(cf->operand)) + { + case HCL_CONCODE_ARRAY: + if (compile_cons_array_expression(hcl, cf->operand) <= -1) return -1; + break; +/* + case HCL_CONCODE_BYTEARRA: + 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; + break; + + /* TODO: QLIST? */ + default: + if (compile_cons_xlist_expression (hcl, cf->operand) <= -1) return -1; + break; + } break; + } case HCL_BRAND_SYMBOL_ARRAY: - hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARDCLBANNED, HCL_NULL, HCL_NULL, "variable declaration disallowed - %O", cf->operand); /* TODO: error location */ + hcl_setsynerrbfmt ( + hcl, HCL_SYNERR_VARDCLBANNED, HCL_NULL, HCL_NULL, + "variable declaration disallowed - %O", cf->operand); /* TODO: error location */ return -1; default: @@ -1404,8 +1494,9 @@ static int compile_object_list (hcl_t* hcl) if (!HCL_IS_CONS(hcl, coperand)) { - HCL_DEBUG1 (hcl, "Syntax error - redundant cdr in the object list - %O\n", coperand); - hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */ + hcl_setsynerrbfmt ( + hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in the object list - %O", coperand); /* TODO: error location */ return -1; } @@ -1460,6 +1551,106 @@ static int compile_object_list (hcl_t* hcl) done: return 0; } + +static int compile_array_list (hcl_t* hcl) +{ + hcl_cframe_t* cf; + hcl_oop_t coperand; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_ARRAY_LIST); + + coperand = cf->operand; + + if (HCL_IS_NIL(hcl, coperand)) + { + POP_CFRAME (hcl); + } + else + { + hcl_oop_t car, cdr; + hcl_ooi_t oldidx; + + if (!HCL_IS_CONS(hcl, coperand)) + { + hcl_setsynerrbfmt ( + hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in the array list - %O", coperand); /* TODO: error location */ + return -1; + } + + car = HCL_CONS_CAR(coperand); + cdr = HCL_CONS_CDR(coperand); + + oldidx = cf->u.array_list.index; + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, car); + if (!HCL_IS_NIL(hcl, cdr)) + { + PUSH_SUBCFRAME (hcl, COP_COMPILE_ARRAY_LIST, cdr); + cf = GET_SUBCFRAME(hcl); + cf->u.array_list.index = oldidx + 1; + } + + PUSH_SUBCFRAME (hcl, COP_EMIT_POP_INTO_ARRAY, HCL_SMOOI_TO_OOP(oldidx)); + } + + return 0; +} + +static int compile_dictionary_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); + + coperand = cf->operand; + + if (HCL_IS_NIL(hcl, coperand)) + { + POP_CFRAME (hcl); + } + else + { + hcl_oop_t car, cdr, cadr, cddr; + + if (!HCL_IS_CONS(hcl, coperand)) + { + hcl_setsynerrbfmt ( + hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, + "redundant cdr in the dictionary list - %O", coperand); /* TODO: error location */ + return -1; + } + + car = HCL_CONS_CAR(coperand); + cdr = HCL_CONS_CDR(coperand); + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, car); + if (HCL_IS_NIL(hcl, cdr)) + { + hcl_setsynerrbfmt ( + hcl, HCL_SYNERR_UNBALKV, HCL_NULL, HCL_NULL, + "no value for key %O", car); + return -1; + } + + cadr = HCL_CONS_CAR(cdr); + cddr = HCL_CONS_CDR(cdr); + + if (!HCL_IS_NIL(hcl, cddr)) + { + PUSH_SUBCFRAME (hcl, COP_COMPILE_DICTIONARY_LIST, cddr); + } + + PUSH_SUBCFRAME (hcl, COP_EMIT_POP_INTO_DICTIONARY, HCL_SMOOI_TO_OOP(0)); + PUSH_SUBCFRAME(hcl, COP_COMPILE_OBJECT, cadr); + } + + return 0; +} + /* ========================================================================= */ static HCL_INLINE int patch_nearest_post_if_body (hcl_t* hcl) @@ -1771,6 +1962,66 @@ static HCL_INLINE int emit_call (hcl_t* hcl) return n; } +static HCL_INLINE int emit_make_array (hcl_t* hcl) +{ + hcl_cframe_t* cf; + int n; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_ARRAY); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + + n = emit_single_param_instruction (hcl, HCL_CODE_MAKE_ARRAY, HCL_OOP_TO_SMOOI(cf->operand)); + + POP_CFRAME (hcl); + return n; +} + + +static HCL_INLINE int emit_make_dictionary (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, HCL_OOP_IS_SMOOI(cf->operand)); + + n = emit_single_param_instruction (hcl, HCL_CODE_MAKE_DICTIONARY, HCL_OOP_TO_SMOOI(cf->operand)); + + POP_CFRAME (hcl); + return n; +} + +static HCL_INLINE int emit_pop_into_array (hcl_t* hcl) +{ + hcl_cframe_t* cf; + int n; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_INTO_ARRAY); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); + + n = emit_single_param_instruction (hcl, HCL_CODE_POP_INTO_ARRAY, HCL_OOP_TO_SMOOI(cf->operand)); + + POP_CFRAME (hcl); + return n; +} + +static HCL_INLINE int emit_pop_into_dictionary (hcl_t* hcl) +{ + hcl_cframe_t* cf; + int n; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_INTO_DICTIONARY); + + n = emit_byte_instruction (hcl, HCL_CODE_POP_INTO_DICTIONARY); + + POP_CFRAME (hcl); + return n; +} + static HCL_INLINE int emit_lambda (hcl_t* hcl) { hcl_cframe_t* cf; @@ -1912,7 +2163,7 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj) switch (cf->opcode) { case COP_COMPILE_OBJECT: - if (compile_object (hcl) <= -1) goto oops; + if (compile_object(hcl) <= -1) goto oops; break; case COP_COMPILE_OBJECT_LIST: @@ -1920,19 +2171,43 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj) case COP_COMPILE_IF_OBJECT_LIST: case COP_COMPILE_IF_OBJECT_LIST_TAIL: case COP_COMPILE_ARGUMENT_LIST: - if (compile_object_list (hcl) <= -1) goto oops; + if (compile_object_list(hcl) <= -1) goto oops; + break; + + case COP_COMPILE_ARRAY_LIST: + if (compile_array_list(hcl) <= -1) goto oops; + break; + + case COP_COMPILE_DICTIONARY_LIST: + if (compile_dictionary_list(hcl) <= -1) goto oops; break; case COP_EMIT_CALL: - if (emit_call (hcl) <= -1) goto oops; + if (emit_call(hcl) <= -1) goto oops; + break; + + case COP_EMIT_MAKE_ARRAY: + if (emit_make_array(hcl) <= -1) goto oops; + break; + + case COP_EMIT_MAKE_DICTIONARY: + if (emit_make_dictionary(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; break; case COP_EMIT_LAMBDA: - if (emit_lambda (hcl) <= -1) goto oops; + if (emit_lambda(hcl) <= -1) goto oops; break; case COP_EMIT_POP_STACKTOP: - if (emit_pop_stacktop (hcl) <= -1) goto oops; + if (emit_pop_stacktop(hcl) <= -1) goto oops; break; case COP_EMIT_RETURN: diff --git a/lib/decode.c b/lib/decode.c index b597eb3..175258e 100644 --- a/lib/decode.c +++ b/lib/decode.c @@ -493,6 +493,27 @@ int hcl_decode (hcl_t* hcl, hcl_ooi_t start, hcl_ooi_t end) break; /* -------------------------------------------------------- */ + case HCL_CODE_MAKE_ARRAY: + FETCH_PARAM_CODE_TO (hcl, b1); + LOG_INST_1 (hcl, "make_array %zu", b1); + break; + + case HCL_CODE_POP_INTO_ARRAY: + FETCH_PARAM_CODE_TO (hcl, b1); + LOG_INST_1 (hcl, "pop_into_array %zu", b1); + break; + + case HCL_CODE_MAKE_DICTIONARY: + FETCH_PARAM_CODE_TO (hcl, b1); + LOG_INST_1 (hcl, "make_dictionary %zu", b1); + break; + + case HCL_CODE_POP_INTO_DICTIONARY: + LOG_INST_0 (hcl, "pop_into_dictionary"); + break; + + /* -------------------------------------------------------- */ + case BCODE_DUP_STACKTOP: LOG_INST_0 (hcl, "dup_stacktop"); break; diff --git a/lib/dic.c b/lib/dic.c index a3b32f7..2133354 100644 --- a/lib/dic.c +++ b/lib/dic.c @@ -71,10 +71,10 @@ 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) { - HCL_ASSERT (hcl, HCL_BRANDOF(hcl,ass) == HCL_BRAND_CONS); + HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass)); key = (hcl_oop_char_t)ass->car; - HCL_ASSERT (hcl, HCL_BRANDOF(hcl,key) == HCL_BRAND_SYMBOL); + HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % newsz; while (newbuc->slot[index] != hcl->_nil) index = (index + 1) % newsz; @@ -105,8 +105,8 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_set_t dic, hcl_oop_cha { ass = (hcl_oop_cons_t)dic->bucket->slot[index]; - HCL_ASSERT (hcl, HCL_BRANDOF(hcl,ass) == HCL_BRAND_CONS); - HCL_ASSERT (hcl, HCL_BRANDOF(hcl,ass->car) == HCL_BRAND_SYMBOL); + 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))) @@ -198,7 +198,7 @@ static hcl_oop_cons_t lookup (hcl_t* hcl, hcl_oop_set_t dic, const hcl_oocs_t* n hcl_oop_cons_t ass; HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(dic->tally)); - HCL_ASSERT (hcl, HCL_BRANDOF(hcl,dic->bucket) == HCL_BRAND_ARRAY); + HCL_ASSERT (hcl, HCL_IS_ARRAY(hcl,dic->bucket)); index = hcl_hashoochars(name->ptr, name->len) % HCL_OBJ_GET_SIZE(dic->bucket); @@ -206,8 +206,8 @@ static hcl_oop_cons_t lookup (hcl_t* hcl, hcl_oop_set_t dic, const hcl_oocs_t* n { ass = (hcl_oop_cons_t)dic->bucket->slot[index]; - HCL_ASSERT (hcl, HCL_BRANDOF(hcl,ass) == HCL_BRAND_CONS); - HCL_ASSERT (hcl, HCL_BRANDOF(hcl,ass->car) == HCL_BRAND_SYMBOL); + 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)) @@ -242,13 +242,13 @@ 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_t key, hcl_oop_t value) { - HCL_ASSERT (hcl, HCL_BRANDOF(hcl,key) == HCL_BRAND_SYMBOL); + HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); 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_ASSERT (hcl, HCL_BRANDOF(hcl,key) == HCL_BRAND_SYMBOL); + HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); return find_or_upsert (hcl, dic, (hcl_oop_char_t)key, HCL_NULL); } diff --git a/lib/gc.c b/lib/gc.c index ce505f3..3e32985 100644 --- a/lib/gc.c +++ b/lib/gc.c @@ -333,6 +333,8 @@ void hcl_gc (hcl_t* hcl) for (i = 0; i < hcl->code.lit.len; i++) { + /* the literal array ia a NGC object. but the literal objects + * pointed by the elements of this array must be gabage-collected. */ ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[i] = hcl_moveoop (hcl, ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[i]); } diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index d1bfa95..b1175f8 100644 --- a/lib/hcl-prv.h +++ b/lib/hcl-prv.h @@ -307,6 +307,11 @@ struct hcl_cframe_t { hcl_ooi_t body_pos; } post_if; + + struct + { + hcl_ooi_t index; + } array_list; } u; }; diff --git a/lib/hcl.h b/lib/hcl.h index 1f26fb2..da471fe 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -149,7 +149,8 @@ enum hcl_synerrnum_t HCL_SYNERR_ELSE, /* else without if */ HCL_SYNERR_BREAK, /* break outside loop */ - HCL_SYNERR_CALLABLE /* invalid callable */ + HCL_SYNERR_CALLABLE, /* invalid callable */ + HCL_SYNERR_UNBALKV /* unbalanced key/value pair */ }; typedef enum hcl_synerrnum_t hcl_synerrnum_t; @@ -267,16 +268,16 @@ typedef struct hcl_obj_word_t* hcl_oop_word_t; */ #define HCL_OOP_TAG_BITS 2 -#define HCL_OOP_TAG_SMINT 1 +#define HCL_OOP_TAG_SMOOI 1 #define HCL_OOP_TAG_CHAR 2 -#define HCL_OOP_IS_NUMERIC(oop) (((hcl_oow_t)oop) & (HCL_OOP_TAG_SMINT | HCL_OOP_TAG_CHAR)) +#define HCL_OOP_IS_NUMERIC(oop) (((hcl_oow_t)oop) & (HCL_OOP_TAG_SMOOI | HCL_OOP_TAG_CHAR)) #define HCL_OOP_IS_POINTER(oop) (!HCL_OOP_IS_NUMERIC(oop)) #define HCL_OOP_GET_TAG(oop) (((hcl_oow_t)oop) & HCL_LBMASK(hcl_oow_t, HCL_OOP_TAG_BITS)) -#define HCL_OOP_IS_SMOOI(oop) (((hcl_ooi_t)oop) & HCL_OOP_TAG_SMINT) +#define HCL_OOP_IS_SMOOI(oop) (((hcl_ooi_t)oop) & HCL_OOP_TAG_SMOOI) #define HCL_OOP_IS_CHAR(oop) (((hcl_oow_t)oop) & HCL_OOP_TAG_CHAR) -#define HCL_SMOOI_TO_OOP(num) ((hcl_oop_t)((((hcl_ooi_t)(num)) << HCL_OOP_TAG_BITS) | HCL_OOP_TAG_SMINT)) +#define HCL_SMOOI_TO_OOP(num) ((hcl_oop_t)((((hcl_ooi_t)(num)) << HCL_OOP_TAG_BITS) | HCL_OOP_TAG_SMOOI)) #define HCL_OOP_TO_SMOOI(oop) (((hcl_ooi_t)oop) >> HCL_OOP_TAG_BITS) #define HCL_CHAR_TO_OOP(num) ((hcl_oop_t)((((hcl_oow_t)(num)) << HCL_OOP_TAG_BITS) | HCL_OOP_TAG_CHAR)) #define HCL_OOP_TO_CHAR(oop) (((hcl_oow_t)oop) >> HCL_OOP_TAG_BITS) @@ -1364,6 +1365,7 @@ typedef struct hcl_cons_t* hcl_oop_cons_t; #define HCL_IS_CONTEXT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONTEXT) #define HCL_IS_PROCESS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PROCESS) #define HCL_IS_CONS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONS) +#define HCL_IS_CONS_XLIST(hcl,v) (HCL_IS_CONS(hcl,v) && HCL_OBJ_GET_FLAGS_SYNCODE(v) == HCL_CONCODE_XLIST) #define HCL_IS_ARRAY(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_ARRAY) #define HCL_IS_PRIM(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PRIM) @@ -1773,6 +1775,17 @@ HCL_EXPORT hcl_oop_t hcl_makeprim ( hcl_oow_t maxargs ); +HCL_EXPORT int hcl_hashobj ( + hcl_t* hcl, + hcl_oop_t obj, + hcl_oow_t* xhv +); + +HCL_EXPORT int hcl_equalobjs ( + hcl_t* hcl, + hcl_oop_t rcv, + hcl_oop_t arg +); HCL_EXPORT void hcl_assertfailed ( hcl_t* hcl, diff --git a/lib/main.c b/lib/main.c index 8ede275..037405a 100644 --- a/lib/main.c +++ b/lib/main.c @@ -837,7 +837,8 @@ static char* syntax_error_msg[] = "else without if", "break outside loop", - "invalid callable" + "invalid callable", + "unbalanced key/value pair" }; static void print_synerr (hcl_t* hcl) diff --git a/lib/obj.c b/lib/obj.c index ecccc65..dd8b645 100644 --- a/lib/obj.c +++ b/lib/obj.c @@ -558,3 +558,173 @@ hcl_oop_t hcl_reversecons (hcl_t* hcl, hcl_oop_t cons) return ptr; } + + +/* ------------------------------------------------------------------------ * + * OBJECT HASHING + * ------------------------------------------------------------------------ */ +int hcl_hashobj (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t* xhv) +{ + hcl_oow_t hv; + + switch (HCL_OOP_GET_TAG(obj)) + { + case HCL_OOP_TAG_SMOOI: + hv = HCL_OOP_TO_SMOOI(obj); + break; + +/* + case HCL_OOP_TAG_SMPTR: + hv = (hcl_oow_t)HCL_OOP_TO_SMPTR(obj); + break; +*/ + + case HCL_OOP_TAG_CHAR: + hv = HCL_OOP_TO_CHAR(obj); + break; + +/* + case HCL_OOP_TAG_ERROR: + hv = HCL_OOP_TO_ERROR(obj); + break; +*/ + + default: + { + int type; + + HCL_ASSERT (hcl, HCL_OOP_IS_POINTER(obj)); + type = HCL_OBJ_GET_FLAGS_TYPE(obj); + switch (type) + { + case HCL_OBJ_TYPE_BYTE: + hv = hcl_hashbytes(((hcl_oop_byte_t)obj)->slot, HCL_OBJ_GET_SIZE(obj)); + break; + + case HCL_OBJ_TYPE_CHAR: + hv = hcl_hashoochars (((hcl_oop_char_t)obj)->slot, HCL_OBJ_GET_SIZE(obj)); + break; + + case HCL_OBJ_TYPE_HALFWORD: + hv = hcl_hashhalfwords(((hcl_oop_halfword_t)obj)->slot, HCL_OBJ_GET_SIZE(obj)); + break; + + case HCL_OBJ_TYPE_WORD: + hv = hcl_hashwords(((hcl_oop_word_t)obj)->slot, HCL_OBJ_GET_SIZE(obj)); + break; + + default: + /* HCL_OBJ_TYPE_OOP, ... */ + hcl_seterrbfmt(hcl, HCL_ENOIMPL, "no builtin hash implemented for %O", obj); /* TODO: better error code? */ + return -1; + } + break; + } + } + + /* i assume that hcl_hashxxx() functions limits the return value to fall + * between 0 and HCL_SMOOI_MAX inclusive */ + HCL_ASSERT (hcl, hv >= 0 && hv <= HCL_SMOOI_MAX); + *xhv = hv; + return 0; +} + +/* ------------------------------------------------------------------------ * + * OBJECT EQUALITY + * ------------------------------------------------------------------------ */ +int hcl_equalobjs (hcl_t* hcl, hcl_oop_t rcv, hcl_oop_t arg) +{ + int rtag; + + if (rcv == arg) return 1; /* identical. so equal */ + + rtag = HCL_OOP_GET_TAG(rcv); + if (rtag != HCL_OOP_GET_TAG(arg)) return 0; + + switch (rtag) + { + case HCL_OOP_TAG_SMOOI: + return HCL_OOP_TO_SMOOI(rcv) == HCL_OOP_TO_SMOOI(arg)? 1: 0; + +#if 0 + case HCL_OOP_TAG_SMPTR: + return HCL_OOP_TO_SMPTR(rcv) == HCL_OOP_TO_SMPTR(arg)? 1: 0; +#endif + + case HCL_OOP_TAG_CHAR: + return HCL_OOP_TO_CHAR(rcv) == HCL_OOP_TO_CHAR(arg)? 1: 0; + +#if 0 + case HCL_OOP_TAG_ERROR: + return HCL_OOP_TO_ERROR(rcv) == HCL_OOP_TO_ERROR(arg)? 1: 0; +#endif + + default: + { + HCL_ASSERT (hcl, HCL_OOP_IS_POINTER(rcv)); + + if (HCL_OBJ_GET_CLASS(rcv) != HCL_OBJ_GET_CLASS(arg)) return 0; /* different class, not equal */ + HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_TYPE(rcv) == HCL_OBJ_GET_FLAGS_TYPE(arg)); + + if (HCL_OBJ_GET_CLASS(rcv) == hcl->_class && rcv != arg) + { + /* a class object are supposed to be unique */ + return 0; + } + if (HCL_OBJ_GET_SIZE(rcv) != HCL_OBJ_GET_SIZE(arg)) return 0; /* different size, not equal */ + + switch (HCL_OBJ_GET_FLAGS_TYPE(rcv)) + { + case HCL_OBJ_TYPE_BYTE: + case HCL_OBJ_TYPE_CHAR: + case HCL_OBJ_TYPE_HALFWORD: + case HCL_OBJ_TYPE_WORD: + return (HCL_MEMCMP(HCL_OBJ_GET_BYTE_SLOT(rcv), HCL_OBJ_GET_BYTE_SLOT(arg), HCL_BYTESOF(hcl,rcv)) == 0)? 1: 0; + + default: + { + hcl_oow_t i, size; + + if (rcv == hcl->_nil) return arg == hcl->_nil? 1: 0; + if (rcv == hcl->_true) return arg == hcl->_true? 1: 0; + if (rcv == hcl->_false) return arg == hcl->_false? 1: 0; + + /* HCL_OBJ_TYPE_OOP, ... */ + HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_TYPE(rcv) == HCL_OBJ_TYPE_OOP); + + #if 0 + hcl_seterrbfmt (hcl, HCL_ENOIMPL, "no builtin comparison implemented for %O and %O", rcv, arg); /* TODO: better error code */ + return -1; + #else + + if (HCL_IS_PROCESS(hcl,rcv)) + { + /* the stack in a process object doesn't need to be + * scanned in full. the slots above the stack pointer + * are garbages. */ + size = HCL_PROCESS_NAMED_INSTVARS + + HCL_OOP_TO_SMOOI(((hcl_oop_process_t)rcv)->sp) + 1; + HCL_ASSERT (hcl, size <= HCL_OBJ_GET_SIZE(rcv)); + } + else + { + size = HCL_OBJ_GET_SIZE(rcv); + } + for (i = 0; i < size; i++) + { + int n; + /* TODO: remove recursion */ + /* NOTE: even if the object implements the equality method, + * this primitive method doesn't honor it. */ + n = hcl_equalobjs(hcl, ((hcl_oop_oop_t)rcv)->slot[i], ((hcl_oop_oop_t)arg)->slot[i]); + if (n <= 0) return n; + } + + /* the default implementation doesn't take the trailer space into account */ + return 1; + #endif + } + } + } + } +} diff --git a/lib/read.c b/lib/read.c index 026049e..0165953 100644 --- a/lib/read.c +++ b/lib/read.c @@ -622,9 +622,8 @@ static int get_radix_number (hcl_t* hcl, hcl_ooci_t rc, int radix) if (CHAR_TO_NUM(c, radix) >= radix) { - /* no digit after the radix specifier */ -HCL_DEBUG2 (hcl, "NO DIGIT AFTER RADIX SPECIFIER IN [%.*S] \n", (hcl_ooi_t)hcl->c->tok.name.len, hcl->c->tok.name.ptr); - hcl_setsynerr (hcl, HCL_SYNERR_RADNUMLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_RADNUMLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl), + "no digit after radix specifier in %.*js", hcl->c->tok.name.len, hcl->c->tok.name.ptr); return -1; } @@ -643,8 +642,9 @@ HCL_DEBUG2 (hcl, "NO DIGIT AFTER RADIX SPECIFIER IN [%.*S] \n", (hcl_ooi_t)hcl-> GET_CHAR_TO (hcl, c); } while (!is_delimiter(c)); -HCL_DEBUG2 (hcl, "INVALID DIGIT IN RADIXED NUMBER IN [%.*S] \n", (hcl_ooi_t)hcl->c->tok.name.len, hcl->c->tok.name.ptr); - hcl_setsynerr (hcl, HCL_SYNERR_RADNUMLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); + + hcl_setsynerrbfmt (hcl, HCL_SYNERR_RADNUMLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl), + "invalid digit in radixed number in %.*js", hcl->c->tok.name.len, hcl->c->tok.name.ptr); return -1; } @@ -654,10 +654,9 @@ HCL_DEBUG2 (hcl, "INVALID DIGIT IN RADIXED NUMBER IN [%.*S] \n", (hcl_ooi_t)hcl- return 0; } -static int get_quote_token (hcl_t* hcl) +static int get_quoted_token (hcl_t* hcl) { hcl_ooci_t c; - int radix; HCL_ASSERT (hcl, hcl->c->lxc.c == '\''); @@ -669,9 +668,12 @@ static int get_quote_token (hcl_t* hcl) ADD_TOKEN_CHAR (hcl, '\''); ADD_TOKEN_CHAR(hcl, c); SET_TOKEN_TYPE (hcl, HCL_IOTOK_QPAREN); + break; - //default: - + default: + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ILCHR, TOKEN_LOC(hcl), TOKEN_NAME(hcl), + "invalid quoted token character %jc", c); + return -1; } return 0; @@ -743,8 +745,8 @@ static int get_sharp_token (hcl_t* hcl) GET_CHAR_TO (hcl, c); if (is_delimiter(c)) { -HCL_DEBUG2 (hcl, "NO VALID CHARACTER AFTER #\\ in [%.*S]\n", (hcl_ooi_t)hcl->c->tok.name.len, hcl->c->tok.name.ptr); - hcl_setsynerr (hcl, HCL_SYNERR_CHARLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_CHARLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl), + "no valid character after #\\ in %.*js", hcl->c->tok.name.len, hcl->c->tok.name.ptr); return -1; } @@ -767,8 +769,8 @@ HCL_DEBUG2 (hcl, "NO VALID CHARACTER AFTER #\\ in [%.*S]\n", (hcl_ooi_t)hcl->c-> { if (!is_xdigitchar(hcl->c->tok.name.ptr[i])) { -HCL_DEBUG2 (hcl, "INVALID HEX-CHARACTER IN [%.*S]\n", (hcl_ooi_t)hcl->c->tok.name.len, hcl->c->tok.name.ptr); - hcl_setsynerr (hcl, HCL_SYNERR_CHARLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_CHARLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl), + "invalid hexadecimal character in %.*js", hcl->c->tok.name.len, hcl->c->tok.name.ptr); return -1; } @@ -818,8 +820,8 @@ HCL_DEBUG2 (hcl, "INVALID HEX-CHARACTER IN [%.*S]\n", (hcl_ooi_t)hcl->c->tok.nam } else { -HCL_DEBUG2 (hcl, "INVALID CHARACTER LITERAL [%.*S]\n", (hcl_ooi_t)hcl->c->tok.name.len, hcl->c->tok.name.ptr); - hcl_setsynerr (hcl, HCL_SYNERR_CHARLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_CHARLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl), + "invalid character literal %.*js", hcl->c->tok.name.len, hcl->c->tok.name.ptr); return -1; } } @@ -889,8 +891,8 @@ HCL_DEBUG2 (hcl, "INVALID CHARACTER LITERAL [%.*S]\n", (hcl_ooi_t)hcl->c->tok.na } else { -HCL_DEBUG2 (hcl, "INVALID HASHED LITERAL NAME [%.*S]\n", (hcl_ooi_t)hcl->c->tok.name.len, hcl->c->tok.name.ptr); - hcl_setsynerr (hcl, HCL_SYNERR_HASHLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_HASHLIT, TOKEN_LOC(hcl), TOKEN_NAME(hcl), + "invalid hashed literal name %.*js", hcl->c->tok.name.len, hcl->c->tok.name.ptr); return -1; } @@ -966,28 +968,26 @@ retry: break; case '}': - ADD_TOKEN_CHAR(hcl, c); + ADD_TOKEN_CHAR (hcl, c); SET_TOKEN_TYPE (hcl, HCL_IOTOK_RBRACE); break; case '|': ADD_TOKEN_CHAR (hcl, c); - SET_TOKEN_TYPE(hcl, HCL_IOTOK_VBAR); + SET_TOKEN_TYPE (hcl, HCL_IOTOK_VBAR); break; case '.': SET_TOKEN_TYPE (hcl, HCL_IOTOK_DOT); - ADD_TOKEN_CHAR(hcl, c); + ADD_TOKEN_CHAR (hcl, c); break; - - case '\"': if (get_string(hcl, '\"', '\\', 0, 0) <= -1) return -1; break; case '\'': - if (get_quote_token(hcl) <= -1) return -1; + if (get_quoted_token(hcl) <= -1) return -1; break; case '#': @@ -1263,7 +1263,7 @@ static HCL_INLINE hcl_oop_t enter_list (hcl_t* hcl, int flagv) static HCL_INLINE hcl_oop_t leave_list (hcl_t* hcl, int* flagv, int* oldflagv) { hcl_oop_t head; - int fv; + int fv, concode; /* the stack must not be empty - cannot leave a list without entering it */ HCL_ASSERT (hcl, !HCL_IS_NIL(hcl,hcl->c->r.s)); @@ -1277,10 +1277,12 @@ static HCL_INLINE hcl_oop_t leave_list (hcl_t* hcl, int* flagv, int* oldflagv) pop (hcl); fv = HCL_OOP_TO_SMOOI(HCL_CONS_CAR(hcl->c->r.s)); + concode = LIST_FLAG_GET_CONCODE(fv); pop (hcl); #if 0 - if (fv & ARRAY) + /* TODO: literalize the list if all the elements are all literals */ + if (concode == HCL_CONCODE_ARRAY) { /* convert a list to an array */ hcl_oop_oop_t arr; @@ -1291,7 +1293,12 @@ static HCL_INLINE hcl_oop_t leave_list (hcl_t* hcl, int* flagv, int* oldflagv) count = 0; while (ptr != hcl->_nil) { + hcl_oop_t car; HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_BRAND(ptr) == HCL_BRAND_CONS); + car = HCL_CONS_CAR(ptr); + + if (!HCL_OOP_IS_NUMERIC(car)) goto done; /* TODO: check if the element is a literal properly here */ + ptr = HCL_CONS_CDR(ptr); count++; } @@ -1311,6 +1318,7 @@ static HCL_INLINE hcl_oop_t leave_list (hcl_t* hcl, int* flagv, int* oldflagv) head = (hcl_oop_t)arr; } +done: #endif *oldflagv = fv; @@ -1330,7 +1338,22 @@ static HCL_INLINE hcl_oop_t leave_list (hcl_t* hcl, int* flagv, int* oldflagv) } /* return the head of the list being left */ - HCL_OBJ_SET_FLAGS_SYNCODE(head, LIST_FLAG_GET_CONCODE(fv)); + if (HCL_IS_NIL(hcl,head)) + { + /* the list is empty. literalize the empty list according to + * the list opener. for a list, it is same as #nil. */ + switch (concode) + { + case HCL_CONCODE_ARRAY: + 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: + return (hcl_oop_t)hcl_makedic(hcl, 100); /* TODO: default dictionary size for empty definition? */ + } + } + + if (HCL_IS_CONS(hcl,head)) HCL_OBJ_SET_FLAGS_SYNCODE(head, concode); return head; } @@ -1637,14 +1660,14 @@ static int read_object (hcl_t* hcl) flagv = 0; LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_BYTEARRAY); goto start_list; - case HCL_IOTOK_QPAREN: - flagv = 0; - LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_QLIST); - goto start_list; case HCL_IOTOK_DPAREN: flagv = 0; LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_DICTIONARY); goto start_list; + case HCL_IOTOK_QPAREN: + flagv = 0; + LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_QLIST); + goto start_list; case HCL_IOTOK_LPAREN: flagv = 0; LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_XLIST); @@ -1672,8 +1695,8 @@ static int read_object (hcl_t* hcl) /* cannot have a period: * 1. at the top level - not inside () * 2. at the beginning of a list - * 3. inside an array #() */ - hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); + * 3. inside an #(), #[], #{}, () */ + hcl_setsynerr (hcl, HCL_SYNERR_DOTBANNED, TOKEN_LOC(hcl), HCL_NULL); return -1; }