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

enhanced the compiler to handle array enclosed in #().

Browse Source 
added partial code to handle dictionary enclosed in #{}
This commit is contained in:
hyung-hwan 2018-02-07 07:35:30 +00:00
parent 19a672af45
commit 979ba97769
9 changed files with 581 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

323
lib/comp.c
View File

@ -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
* (<operator> <operand1> ...) */
@ -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 <operator> */
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 <operand1> ... 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:

21
lib/decode.c
View File

@ -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;

18
lib/dic.c
View File

@ -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);
}

2
lib/gc.c
View File

@ -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]);
}

5
lib/hcl-prv.h
View File

@ -307,6 +307,11 @@ struct hcl_cframe_t
{
hcl_ooi_t body_pos;
} post_if;
struct
{
hcl_ooi_t index;
} array_list;
} u;
};

23
lib/hcl.h
View File

@ -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,

3
lib/main.c
View File

@ -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)

170
lib/obj.c
View File

@ -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
}
}
}
}
}

87
lib/read.c
View File

@ -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;
}