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

more code to implement class

Browse Source
This commit is contained in:
hyung-hwan 2021-06-27 17:47:51 +00:00
parent 2f2baf2f59
commit 6b476b5c6e
5 changed files with 302 additions and 381 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

616
lib/comp.c
View File

@ -694,6 +694,147 @@ static int emit_indexed_variable_access (hcl_t* hcl, hcl_oow_t index, hcl_oob_t
}
/* ========================================================================= */
static int push_cblk (hcl_t* hcl, const hcl_ioloc_t* errloc, hcl_cblk_type_t type)
{
hcl_oow_t new_depth;
HCL_ASSERT (hcl, hcl->c->cblk.depth >= -1);
if (hcl->c->cblk.depth == HCL_TYPE_MAX(hcl_ooi_t))
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BLKDEPTH, errloc, HCL_NULL, "control block depth too deep");
return -1;
}
new_depth = hcl->c->cblk.depth + 1;
if (hcl->c->cblk.depth >= hcl->c->cblk.info_capa)
{
hcl_cblk_info_t* tmp;
hcl_oow_t newcapa;
newcapa = HCL_ALIGN(new_depth + 1, BLK_INFO_BUFFER_ALIGN);
tmp = (hcl_cblk_info_t*)hcl_reallocmem(hcl, hcl->c->cblk.info, newcapa * HCL_SIZEOF(*tmp));
if (HCL_UNLIKELY(!tmp)) return -1;
hcl->c->cblk.info_capa = newcapa;
hcl->c->cblk.info = tmp;
}
HCL_MEMSET (&hcl->c->cblk.info[new_depth], 0, HCL_SIZEOF(hcl->c->cblk.info[new_depth]));
hcl->c->cblk.info[new_depth]._type = type;
hcl->c->cblk.depth = new_depth;
return 0;
}
static void pop_cblk (hcl_t* hcl)
{
HCL_ASSERT (hcl, hcl->c->cblk.depth >= 0); /* depth is of a signed type */
/* a control block stays inside a function block.
* the control block stack must not be popped past the starting base
* of the owning function block */
HCL_ASSERT (hcl, hcl->c->cblk.depth - 1 >= hcl->c->fnblk.info[hcl->c->fnblk.depth].cblk_base);
hcl->c->cblk.depth--;
}
static int push_clsblk (hcl_t* hcl, const hcl_ioloc_t* errloc, hcl_oow_t nivars, hcl_oow_t ncvars, const hcl_ooch_t* ivars_str, const hcl_ooch_t* cvars_str)
{
hcl_oow_t new_depth;
hcl_clsblk_info_t* ci;
hcl_fnblk_info_t* fbi;
HCL_ASSERT (hcl, hcl->c->clsblk.depth >= -1);
if (hcl->c->clsblk.depth == HCL_TYPE_MAX(hcl_ooi_t))
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BLKDEPTH, errloc, HCL_NULL, "class block depth too deep");
return -1;
}
new_depth = hcl->c->clsblk.depth + 1;
if (hcl->c->clsblk.depth >= hcl->c->clsblk.info_capa)
{
hcl_clsblk_info_t* tmp;
hcl_oow_t newcapa;
newcapa = HCL_ALIGN(new_depth + 1, BLK_INFO_BUFFER_ALIGN);
tmp = (hcl_clsblk_info_t*)hcl_reallocmem(hcl, hcl->c->clsblk.info, newcapa * HCL_SIZEOF(*tmp));
if (HCL_UNLIKELY(!tmp)) return -1;
hcl->c->clsblk.info_capa = newcapa;
hcl->c->clsblk.info = tmp;
}
ci = &hcl->c->clsblk.info[new_depth];
HCL_MEMSET (ci, 0, HCL_SIZEOF(*ci));
ci->nivars = nivars;
ci->ncvars = ncvars;
if (ivars_str)
{
HCL_ASSERT (hcl, ci->nivars > 0);
ci->ivars_str = hcl_dupoocstr(hcl, ivars_str, HCL_NULL);
if (HCL_UNLIKELY(!ci->ivars_str)) return -1;
}
if (cvars_str)
{
HCL_ASSERT (hcl, ci->ncvars > 0);
ci->cvars_str = hcl_dupoocstr(hcl, cvars_str, HCL_NULL);
if (HCL_UNLIKELY(!ci->cvars_str))
{
if (ci->ivars_str) hcl_freemem (hcl, ci->ivars_str);
return -1;
}
}
/* remember the function block depth before the class block is entered */
ci->fnblk_base = hcl->c->fnblk.depth;
/* attach the class block to the current function block */
fbi = &hcl->c->fnblk.info[hcl->c->fnblk.depth];
if (fbi->clsblk_base <= -1) fbi->clsblk_base = new_depth;
fbi->clsblk_top = new_depth;
hcl->c->clsblk.depth = new_depth;
return 0;
}
static void pop_clsblk (hcl_t* hcl)
{
hcl_fnblk_info_t* fbi;
hcl_clsblk_info_t* cbi;
HCL_ASSERT (hcl, hcl->c->clsblk.depth >= 0); /* depth is of a signed type */
HCL_ASSERT (hcl, hcl->c->fnblk.depth >= 0);
fbi = &hcl->c->fnblk.info[hcl->c->fnblk.depth];
HCL_ASSERT (hcl, fbi->clsblk_base >= 0 && fbi->clsblk_top >= 0 && fbi->clsblk_top >= fbi->clsblk_base);
HCL_ASSERT (hcl, fbi->clsblk_top == hcl->c->clsblk.depth);
if (fbi->clsblk_top == fbi->clsblk_base)
{
/* the first class block inside a function block */
fbi->clsblk_base = -1;
fbi->clsblk_top = -1;
}
else
{
fbi->clsblk_top--;
}
cbi = &hcl->c->clsblk.info[hcl->c->clsblk.depth];
if (cbi->cvars_str)
{
hcl_freemem (hcl, cbi->cvars_str);
cbi->cvars_str = HCL_NULL;
}
if (cbi->ivars_str)
{
hcl_freemem (hcl, cbi->ivars_str);
cbi->ivars_str = HCL_NULL;
}
hcl->c->clsblk.depth--;
}
static int push_fnblk (hcl_t* hcl, const hcl_ioloc_t* errloc,
hcl_oow_t tmpr_va, hcl_oow_t tmpr_nargs, hcl_oow_t tmpr_nrvars, hcl_oow_t tmpr_nlvars,
@ -749,6 +890,14 @@ static int push_fnblk (hcl_t* hcl, const hcl_ioloc_t* errloc,
return 0;
}
static void clear_fnblk_inners (hcl_t* hcl)
{
hcl_fnblk_info_t* fbi;
fbi = &hcl->c->fnblk.info[hcl->c->fnblk.depth];
while (hcl->c->cblk.depth > fbi->cblk_base) pop_cblk (hcl);
while (!(fbi->clsblk_base <= -1 && fbi->clsblk_top <= -1)) pop_clsblk (hcl);
}
static void pop_fnblk (hcl_t* hcl)
{
hcl_fnblk_info_t* fbi;
@ -757,9 +906,12 @@ static void pop_fnblk (hcl_t* hcl)
/* if pop_cblk() has been called properly, the following assertion must be true
* and the assignment on the next line isn't necessary */
clear_fnblk_inners (hcl);
fbi = &hcl->c->fnblk.info[hcl->c->fnblk.depth];
HCL_ASSERT (hcl, hcl->c->cblk.depth == fbi->cblk_base);
HCL_ASSERT (hcl, fbi->clsblk_base <= -1 && fbi->clsblk_top <= -1);
hcl->c->cblk.depth = fbi->cblk_base;
/* keep hcl->code.lit.len without restoration */
@ -795,117 +947,6 @@ static void pop_fnblk (hcl_t* hcl)
}
}
static int push_cblk (hcl_t* hcl, const hcl_ioloc_t* errloc, hcl_cblk_type_t type)
{
hcl_oow_t new_depth;
HCL_ASSERT (hcl, hcl->c->cblk.depth >= -1);
if (hcl->c->cblk.depth == HCL_TYPE_MAX(hcl_ooi_t))
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BLKDEPTH, errloc, HCL_NULL, "control block depth too deep");
return -1;
}
new_depth = hcl->c->cblk.depth + 1;
if (hcl->c->cblk.depth >= hcl->c->cblk.info_capa)
{
hcl_cblk_info_t* tmp;
hcl_oow_t newcapa;
newcapa = HCL_ALIGN(new_depth + 1, BLK_INFO_BUFFER_ALIGN);
tmp = (hcl_cblk_info_t*)hcl_reallocmem(hcl, hcl->c->cblk.info, newcapa * HCL_SIZEOF(*tmp));
if (HCL_UNLIKELY(!tmp)) return -1;
hcl->c->cblk.info_capa = newcapa;
hcl->c->cblk.info = tmp;
}
HCL_MEMSET (&hcl->c->cblk.info[new_depth], 0, HCL_SIZEOF(hcl->c->cblk.info[new_depth]));
hcl->c->cblk.info[new_depth]._type = type;
hcl->c->cblk.depth = new_depth;
return 0;
}
static void pop_cblk (hcl_t* hcl)
{
HCL_ASSERT (hcl, hcl->c->cblk.depth >= 0); /* depth is of a signed type */
/* a control block stays inside a function block.
* the control block stack must not be popped past the starting base
* of the owning function block */
HCL_ASSERT (hcl, hcl->c->cblk.depth - 1 >= hcl->c->fnblk.info[hcl->c->fnblk.depth].cblk_base);
hcl->c->cblk.depth--;
}
static int push_clsblk (hcl_t* hcl, const hcl_ioloc_t* errloc, hcl_oow_t nivars, hcl_oow_t ncvars)
{
hcl_oow_t new_depth;
hcl_clsblk_info_t* ci;
hcl_fnblk_info_t* fbi;
HCL_ASSERT (hcl, hcl->c->clsblk.depth >= -1);
if (hcl->c->clsblk.depth == HCL_TYPE_MAX(hcl_ooi_t))
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BLKDEPTH, errloc, HCL_NULL, "class block depth too deep");
return -1;
}
new_depth = hcl->c->clsblk.depth + 1;
if (hcl->c->clsblk.depth >= hcl->c->clsblk.info_capa)
{
hcl_clsblk_info_t* tmp;
hcl_oow_t newcapa;
newcapa = HCL_ALIGN(new_depth + 1, BLK_INFO_BUFFER_ALIGN);
tmp = (hcl_clsblk_info_t*)hcl_reallocmem(hcl, hcl->c->clsblk.info, newcapa * HCL_SIZEOF(*tmp));
if (HCL_UNLIKELY(!tmp)) return -1;
hcl->c->clsblk.info_capa = newcapa;
hcl->c->clsblk.info = tmp;
}
ci = &hcl->c->clsblk.info[new_depth];
HCL_MEMSET (ci, 0, HCL_SIZEOF(*ci));
ci->nivars = nivars;
ci->ncvars = ncvars;
/* remember the function block depth before the class block is entered */
ci->fnblk_base = hcl->c->fnblk.depth;
/* attach the class block to the current function block */
fbi = &hcl->c->fnblk.info[hcl->c->fnblk.depth];
if (fbi->clsblk_base <= -1) fbi->clsblk_base = new_depth;
fbi->clsblk_top = new_depth;
hcl->c->clsblk.depth = new_depth;
return 0;
}
static void pop_clsblk (hcl_t* hcl)
{
hcl_fnblk_info_t* fbi;
HCL_ASSERT (hcl, hcl->c->clsblk.depth >= 0); /* depth is of a signed type */
HCL_ASSERT (hcl, hcl->c->fnblk.depth >= 0);
fbi = &hcl->c->fnblk.info[hcl->c->fnblk.depth];
HCL_ASSERT (hcl, fbi->clsblk_base >= 0 && fbi->clsblk_top >= 0 && fbi->clsblk_top >= fbi->clsblk_base);
HCL_ASSERT (hcl, fbi->clsblk_top == hcl->c->clsblk.depth);
if (fbi->clsblk_top == fbi->clsblk_base)
{
fbi->clsblk_base = -1;
fbi->clsblk_top = -1;
}
else
{
fbi->clsblk_top--;
}
hcl->c->clsblk.depth--;
}
/* ========================================================================= */
static HCL_INLINE int _insert_cframe (hcl_t* hcl, hcl_ooi_t index, int opcode, hcl_cnode_t* operand)
{
@ -1692,6 +1733,69 @@ static HCL_INLINE int compile_else (hcl_t* hcl)
/* ========================================================================= */
static int collect_vardcl (hcl_t* hcl, hcl_cnode_t* obj, hcl_cnode_t** nextobj, hcl_oow_t tv_dup_check_start, hcl_oow_t* nvardcls, const hcl_bch_t* desc)
{
hcl_oow_t ndcls = 0;
while (obj && HCL_CNODE_IS_CONS(obj))
{
hcl_cnode_t* dcl;
dcl = HCL_CNODE_CONS_CAR(obj);
if (HCL_CNODE_IS_CONS_CONCODED(dcl, HCL_CONCODE_VLIST))
{
hcl_cnode_t* var;
do
{
var = HCL_CNODE_CONS_CAR(dcl);
#if 0
if (!HCL_CNODE_IS_SYMBOL(var))
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAME, HCL_CNODE_GET_LOC(var), HCL_CNODE_GET_TOK(var), "local variable not a symbol");
return -1;
}
if (HCL_CNODE_IS_SYMBOL(var) && HCL_CNODE_SYMBOL_SYNCODE(var) /* || HCL_OBJ_GET_FLAGS_KERNEL(var) >= 2 */)
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDARGNAME, HCL_CNODE_GET_LOC(var), HCL_CNODE_GET_TOK(var), "special symbol not to be declared as a local variable");
return -1;
}
#else
/* the above checks are not needed as the reader guarantees the followings */
HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_PLAIN(var));
#endif
if (add_temporary_variable(hcl, HCL_CNODE_GET_TOK(var), tv_dup_check_start) <= -1)
{
if (hcl->errnum == HCL_EEXIST)
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMEDUP, HCL_CNODE_GET_LOC(var), HCL_CNODE_GET_TOK(var), "duplicate %hs variable", desc);
}
return -1;
}
ndcls++;
dcl = HCL_CNODE_CONS_CDR(dcl);
if (!dcl) break;
if (!HCL_CNODE_IS_CONS(dcl))
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(dcl), HCL_CNODE_GET_TOK(dcl), "redundant cdr in %hs variable list", desc);
return -1;
}
}
while (1);
obj = HCL_CNODE_CONS_CDR(obj);
}
else break;
}
*nvardcls = ndcls;
*nextobj = obj;
return 0;
}
static int check_if_plain_cnode (hcl_t* hcl, hcl_cnode_t* obj, hcl_cnode_t* prev, hcl_cnode_t* container, hcl_synerrnum_t errnum, const hcl_bch_t* bname)
{
if (!obj)
@ -1708,9 +1812,6 @@ static int check_if_plain_cnode (hcl_t* hcl, hcl_cnode_t* obj, hcl_cnode_t* prev
return 0;
}
#if 0
static int compile_class (hcl_t* hcl, hcl_cnode_t* src)
{
/*
(defclass A
| x y | ; instance variables
@ -1738,155 +1839,6 @@ static int compile_class (hcl_t* hcl, hcl_cnode_t* src)
)
*/
hcl_cnode_t* cmd, * obj, * tmp;
hcl_cnode_t* class_name, * superclass_name;
hcl_ooi_t nsuperclasses, nivars, ncvars;
cmd = HCL_CNODE_CONS_CAR(src);
obj = HCL_CNODE_CONS_CDR(src);
HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(cmd, HCL_SYNCODE_DEFCLASS));
class_name = HCL_NULL;
superclass_name = HCL_NULL;
if (check_if_plain_cnode(hcl, obj, src, cmd, HCL_SYNERR_VARNAME, "class name") <= -1) return -1;
class_name = HCL_CNODE_CONS_CAR(obj);
if (HCL_CNODE_IS_SYMBOL(class_name))
{
/* defclass followed by a class name */
if (HCL_CNODE_SYMBOL_SYNCODE(class_name)) /*|| HCL_OBJ_GET_FLAGS_KERNEL(class_name) >= 1) */
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_CNODE_GET_LOC(class_name), HCL_CNODE_GET_TOK(class_name), "special symbol not to be used as a class name");
return -1;
}
obj = HCL_CNODE_CONS_CDR(obj);
}
if (obj)
{
/* superclass */
tmp = HCL_CNODE_CONS_CAR(obj);
if (HCL_CNODE_IS_TRPCOLONS(tmp))
{
obj = HCL_CNODE_CONS_CDR(obj);
/* TODO: this can actually be dynamic. so it doesn't have to be a symbol name,
* even an expression is possible ...
* (defclass A
* ...
* )
* (defun get-your-class() A)
* (defclass B ::: (get-your-class)
* ....
* )
*
* this code is wrong...
*/
#if 0
/* TODO: multiple subclasses? interfaces? */
if (check_if_plain_cnode(hcl, obj, tmp, cmd, HCL_SYNERR_VARNAME, "superclass name") <= -1) return -1;
superclass_name = HCL_CNODE_CONS_CAR(obj);
if (HCL_CNODE_IS_SYMBOL(superclass_name))
{
if (HCL_CNODE_SYMBOL_SYNCODE(superclass_name)) /*|| HCL_OBJ_GET_FLAGS_KERNEL(superclass_name) >= 1) */
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_CNODE_GET_LOC(superclass_name), HCL_CNODE_GET_TOK(superclass_name), "special symbol not to be used as a superclass name");
return -1;
}
obj = HCL_CNODE_CONS_CDR(obj);
}
else
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_CNODE_GET_LOC(superclass_name), HCL_CNODE_GET_TOK(superclass_name), "non-symbol not to be used as a superclass name");
return -1;
}
#else
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, expr); /* 1 */
PUSH_SUBCFRAME (hcl, COP_COMPILE_AND_P2, expr); /* 3 */
cf = GET_SUBCFRAME(hcl);
cf->u.post_and.jump_inst_pos = jump_inst_pos;
if (obj) PUSH_SUBCFRAME (hcl, COP_COMPILE_AND_P1, obj); /* 2 */
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, obj); /* 1 */
#endif
}
else
{
SWITCH_TO_CFRAME (hcl, COP_EMIT_PUSH_NIL, obj); /* 1*/
}
}
PUSH_SUBCFRAME (hcl, COP_CLASS_SUPERCLASS
#if 0
//HCL_DEBUG2 (hcl, ">>> [%js] [%js]\n", HCL_CNODE_GET_TOKPTR(class_name), HCL_CNODE_GET_TOKPTR(superclass_name));
nivars = ncvars = 0;
while (obj)
{
/* instance variables and/or class variables */
hcl_cnode_t* vars;
printf ("VLIST....\n");
if (check_if_plain_cnode(hcl, obj, src, cmd, HCL_SYNERR_VARNAME, "variable list") <= -1) return -1;
vars = HCL_CNODE_CONS_CAR(obj);
if (!HCL_CNODE_IS_CONS_CONCODED(vars, HCL_CONCODE_VLIST)) break;
// TODO increment nivars and ncvars
// also remember actual variable names...
printf ("22222222222\n");
obj = HCL_CNODE_CONS_CDR(obj);
}
#else
PUSH_SUBCFRAME (hcl, COP_COMPILE_CLASS_VARS, obj);
#endif
// superclass name?
// nivars and ncvars.. must include inherited ones...
if (push_clsblk(hcl, HCL_CNODE_GET_LOC(cmd), nivars, ncvars) <= -1) return -1;
/* TODO: push the instance variables string and class variables string */
// superclass name is an variable...
//if (emit_push_literal(hcl, tmp, HCL_CNODE_GET_LOC(cmd))
if (nivars > 0)
{
tmp = hcl_makestring(hcl, varg, len, 0);
if (HCL_UNLIKELY(!tmp)) return -1;
if (emit_push_literal(hcl, tmp, HCL_CNODE_GET_LOC(cmd)) <= -1) return-1;
}
if (ncvars > 0)
{
}
/* make_class nsuperclasses, nivars, ncvars - this will use the pushed literal */
if (emit_byte_instruction(hcl, HCL_CODE_MAKE_CLASS, HCL_CNODE_GET_LOC(cmd)) <= -1) return -1;
if (emit_long_param(hcl, nivars) <= -1) return -1;
if (emit_long_param(hcl, ncvars) <= -1) return -1;
if (emit_byte_instruction(hcl, HCL_CODE_CLASS_ENTER, HCL_CNODE_GET_LOC(cmd)) <= -1) return -1;
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_LIST, obj); /* 1 */
PUSH_SUBCFRAME (hcl, COP_POST_CLASS, class_name); /* 2*/
return 0;
}
#endif
static int compile_class (hcl_t* hcl, hcl_cnode_t* src)
{
@ -1962,56 +1914,49 @@ static HCL_INLINE int compile_class_p1 (hcl_t* hcl)
hcl_ooi_t nivars, ncvars;
hcl_cnode_t* obj;
hcl_oop_t tmp;
hcl_oow_t saved_tv_wcount, tv_dup_start;
cf = GET_TOP_CFRAME(hcl);
obj = cf->operand;
saved_tv_wcount = hcl->c->tv.wcount;
tv_dup_start = hcl->c->tv.s.len;
/* TODO: class variables */
nivars = ncvars = 0;
while (obj)
{
/* instance variables and/or class variables */
hcl_cnode_t* vars;
if (collect_vardcl(hcl, obj, &obj, tv_dup_start, &nivars, "instance") <= -1) goto oops;
HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(obj)); /* must not get CDR. the reader must ensure this */
vars = HCL_CNODE_CONS_CAR(obj);
if (!HCL_CNODE_IS_CONS_CONCODED(vars, HCL_CONCODE_VLIST)) break;
// TODO increment nivars and ncvars
// also remember actual variable names...
obj = HCL_CNODE_CONS_CDR(obj);
}
/* TODO: push the instance variables string and class variables string */
// superclass name is an variable...
//if (emit_push_literal(hcl, tmp, HCL_CNODE_GET_LOC(cmd))
if (nivars > 0)
{
//tmp = hcl_makestring(hcl, varg, len, 0);
tmp = hcl_makestring(hcl, HCL_NULL, 0, 0);
if (HCL_UNLIKELY(!tmp)) return -1;
if (emit_push_literal(hcl, tmp, &cf->u._class.start_loc) <= -1) return-1;
/* set starting point past the added space (+1 to index, -1 to length) */
tmp = hcl_makestring(hcl, &hcl->c->tv.s.ptr[tv_dup_start + 1], hcl->c->tv.s.len - tv_dup_start - 1, 0);
if (HCL_UNLIKELY(!tmp)) goto oops;
if (emit_push_literal(hcl, tmp, &cf->u._class.start_loc) <= -1) goto oops;
}
if (ncvars > 0)
{
tmp = hcl_makestring(hcl, HCL_NULL, 0, 0);
if (HCL_UNLIKELY(!tmp)) return -1;
if (emit_push_literal(hcl, tmp, &cf->u._class.start_loc) <= -1) return-1;
tmp = hcl_makestring(hcl, HCL_NULL, 0, 0); /* TODO: set this to the proper string pointer and length ... */
if (HCL_UNLIKELY(!tmp)) goto oops;
if (emit_push_literal(hcl, tmp, &cf->u._class.start_loc) <= -1) goto oops;
}
if (push_clsblk(hcl, &cf->u._class.start_loc, nivars, ncvars) <= -1) return -1;
if (push_clsblk(hcl, &cf->u._class.start_loc, nivars, ncvars, &hcl->c->tv.s.ptr[tv_dup_start + 1], HCL_NULL) <= -1) goto oops;
/* class_enter nsuperclasses, nivars, ncvars */
if (emit_byte_instruction(hcl, HCL_CODE_CLASS_ENTER, &cf->u._class.start_loc) <= -1) return -1;
if (emit_long_param(hcl, cf->u._class.nsuperclasses) <= -1) return -1;
if (emit_long_param(hcl, nivars) <= -1) return -1;
if (emit_long_param(hcl, ncvars) <= -1) return -1;
if (emit_byte_instruction(hcl, HCL_CODE_CLASS_ENTER, &cf->u._class.start_loc) <= -1) goto oops;
if (emit_long_param(hcl, cf->u._class.nsuperclasses) <= -1) goto oops;
if (emit_long_param(hcl, nivars) <= -1) goto oops;
if (emit_long_param(hcl, ncvars) <= -1) goto oops;
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_LIST, obj); /* 1 */
return 0;
oops:
hcl->c->tv.s.len = tv_dup_start;
hcl->c->tv.wcount = saved_tv_wcount;
return -1;
}
static HCL_INLINE int compile_class_p2 (hcl_t* hcl)
@ -2074,69 +2019,6 @@ static HCL_INLINE int compile_class_p2 (hcl_t* hcl)
/* ========================================================================= */
static int collect_local_vardcl (hcl_t* hcl, hcl_cnode_t* obj, hcl_cnode_t** nextobj, hcl_oow_t tv_dup_check_start, hcl_oow_t* nvardcls)
{
hcl_oow_t ndcls = 0;
while (obj && HCL_CNODE_IS_CONS(obj))
{
hcl_cnode_t* dcl;
dcl = HCL_CNODE_CONS_CAR(obj);
if (HCL_CNODE_IS_CONS_CONCODED(dcl, HCL_CONCODE_VLIST))
{
hcl_cnode_t* var;
do
{
var = HCL_CNODE_CONS_CAR(dcl);
#if 0
if (!HCL_CNODE_IS_SYMBOL(var))
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAME, HCL_CNODE_GET_LOC(var), HCL_CNODE_GET_TOK(var), "local variable not a symbol");
return -1;
}
if (HCL_CNODE_IS_SYMBOL(var) && HCL_CNODE_SYMBOL_SYNCODE(var) /* || HCL_OBJ_GET_FLAGS_KERNEL(var) >= 2 */)
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDARGNAME, HCL_CNODE_GET_LOC(var), HCL_CNODE_GET_TOK(var), "special symbol not to be declared as a local variable");
return -1;
}
#else
/* the above checks are not needed as the reader guarantees the followings */
HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL(var) && !HCL_CNODE_SYMBOL_SYNCODE(var));
#endif
if (add_temporary_variable(hcl, HCL_CNODE_GET_TOK(var), tv_dup_check_start) <= -1)
{
if (hcl->errnum == HCL_EEXIST)
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMEDUP, HCL_CNODE_GET_LOC(var), HCL_CNODE_GET_TOK(var), "duplicate local variable");
}
return -1;
}
ndcls++;
dcl = HCL_CNODE_CONS_CDR(dcl);
if (!dcl) break;
if (!HCL_CNODE_IS_CONS(dcl))
{
hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(dcl), HCL_CNODE_GET_TOK(dcl), "redundant cdr in local variable list");
return -1;
}
}
while (1);
obj = HCL_CNODE_CONS_CDR(obj);
}
else break;
}
*nvardcls = ndcls;
*nextobj = obj;
return 0;
}
static int compile_lambda (hcl_t* hcl, hcl_cnode_t* src, int defun)
{
hcl_cnode_t* cmd, * obj, * args;
@ -2327,7 +2209,7 @@ static int compile_lambda (hcl_t* hcl, hcl_cnode_t* src, int defun)
obj = HCL_CNODE_CONS_CDR(obj);
tv_dup_start = hcl->c->tv.s.len;
if (collect_local_vardcl(hcl, obj, &obj, tv_dup_start, &nlvars) <= -1) return -1;
if (collect_vardcl(hcl, obj, &obj, tv_dup_start, &nlvars, "local") <= -1) return -1;
if (nlvars > MAX_CODE_NBLKLVARS)
{
@ -4553,7 +4435,7 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags)
* pass HCL_TYPE_MAX(hcl_oow_t) as make_inst_pos because there is
* no actual MAKE_BLOCK/MAKE_FUNCTION instruction which otherwise
* would be patched in pop_fnblk(). */
if (push_fnblk(hcl, HCL_NULL, 0, 0, 0, hcl->c->tv.wcount, hcl->c->tv.wcount, hcl->c->tv.s.len, HCL_TYPE_MAX(hcl_oow_t), 0) <= -1) return -1;
if (push_fnblk(hcl, HCL_NULL, 0, 0, 0, hcl->c->tv.wcount, hcl->c->tv.wcount, hcl->c->tv.s.len, HCL_TYPE_MAX(hcl_oow_t), 0) <= -1) return -1; /* must not goto oops */
}
top_fnblk_saved = hcl->c->fnblk.info[0];
HCL_ASSERT (hcl, hcl->c->fnblk.depth == 0); /* ensure the virtual function block is added */
@ -4774,19 +4656,23 @@ oops:
hcl->code.bc.len = saved_bc_len;
hcl->code.lit.len = saved_lit_len;
/* quick way to call pop_cblk() and pop_fnblk() as many times as necessary */
hcl->c->tv.s.len = 0;
hcl->c->tv.wcount = 0;
hcl->c->cblk.depth = -1;
hcl->c->clsblk.depth = -1;
/*hcl->c->fnblk.depth = -1;*/
if (hcl->c->fnblk.depth > 0)
while (hcl->c->fnblk.depth > 0) pop_fnblk (hcl);
if (flags & HCL_COMPILE_CLEAR_FNBLK)
{
hcl->c->fnblk.depth = 0;
pop_fnblk (hcl);
HCL_ASSERT (hcl, hcl->c->fnblk.depth == -1);
}
else
{
/* restore the top level function block as it's first captured in this functio */
clear_fnblk_inners (hcl);
HCL_ASSERT (hcl, hcl->c->fnblk.depth == 0);
hcl->c->fnblk.info[0] = top_fnblk_saved;
}
return -1;
}

37
lib/exec.c
View File

@ -3314,7 +3314,7 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1)
push cvars
class_enter nsuperclasses nivars ncvars
*/
hcl_oop_t t, sc, nivars, ncvars;
hcl_oop_t t, sc, ivars_str, cvars_str;
hcl_oow_t b3;
FETCH_PARAM_CODE_TO (hcl, b1); /* nsuperclasses */
@ -3323,20 +3323,41 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1)
LOG_INST_3 (hcl, "class_enter %zu %zu %zu", b1, b2, b3);
/* TODO: get extra information from the stack according to b1, b2, b3*/
/* critical error if the superclass is not a class ...
* critical error if ivars is not a string...
* critical errro if cvars is not a string ....
*/
t = hcl_makeclass(hcl, hcl->_nil, b2, b3); // TOOD: pass variable information...
if (b3 > 0)
{
HCL_STACK_POP_TO (hcl, cvars_str);
HCL_ASSERT (hcl, HCL_IS_STRING(hcl, cvars_str));
}
else cvars_str = hcl->_nil;
if (b2 > 0)
{
HCL_STACK_POP_TO (hcl, ivars_str);
HCL_ASSERT (hcl, HCL_IS_STRING(hcl, ivars_str));
}
else ivars_str = hcl->_nil;
if (b1 > 0)
{
HCL_STACK_POP_TO (hcl, sc); /* TODO: support more than 1 later when the compiler supports more */
if (!HCL_IS_CLASS(hcl, sc))
{
hcl_seterrbfmt (hcl, HCL_ECALL, "invalid superclass %O", sc);
supplement_errmsg (hcl, fetched_instruction_pointer);
goto oops;
}
}
else sc = hcl->_nil;
t = hcl_makeclass(hcl, sc, b2, b3, ivars_str, cvars_str); // TOOD: pass variable information...
if (HCL_UNLIKELY(!t))
{
supplement_errmsg (hcl, fetched_instruction_pointer);
goto oops;
}
HCL_CLSTACK_PUSH (hcl, t); /* push the class created to the class stack*/
/* push the class created to the class stack. but don't push to the normal operation stack */
HCL_CLSTACK_PUSH (hcl, t);
break;
}

3
lib/hcl-prv.h
View File

@ -216,6 +216,7 @@ typedef enum hcl_cnode_type_t hcl_cnode_type_t;
#define HCL_CNODE_IS_TRPCOLONS(x) ((x)->cn_type == HCL_CNODE_TRPCOLONS)
#define HCL_CNODE_IS_SYMBOL(x) ((x)->cn_type == HCL_CNODE_SYMBOL)
#define HCL_CNODE_IS_SYMBOL_PLAIN(x) ((x)->cn_type == HCL_CNODE_SYMBOL && (x)->u.symbol.syncode == 0)
#define HCL_CNODE_IS_SYMBOL_SYNCODED(x, code) ((x)->cn_type == HCL_CNODE_SYMBOL && (x)->u.symbol.syncode == (code))
#define HCL_CNODE_SYMBOL_SYNCODE(x) ((x)->u.symbol.syncode)
@ -436,6 +437,8 @@ struct hcl_clsblk_info_t
{
hcl_oow_t nivars;
hcl_oow_t ncvars;
hcl_ooch_t* ivars_str;
hcl_ooch_t* cvars_str;
hcl_oow_t spec; /* TODO: byte indexed, word indexed? */
hcl_ooi_t fnblk_base;

10
lib/hcl.h
View File

@ -1712,6 +1712,11 @@ struct hcl_t
#define HCL_STACK_POP(hcl) ((hcl)->sp = (hcl)->sp - 1)
#define HCL_STACK_POPS(hcl,count) ((hcl)->sp = (hcl)->sp - (count))
#define HCL_STACK_POP_TO(hcl,v) \
do { \
v = HCL_STACK_GETTOP(hcl); \
HCL_STACK_POP (hcl); \
} while(0)
#define HCL_STACK_ISEMPTY(hcl) ((hcl)->sp <= -1)
/* get the stack pointer of the argument at the given index */
@ -1829,6 +1834,7 @@ typedef enum hcl_concode_t hcl_concode_t;
#define HCL_IS_CONTEXT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONTEXT)
#define HCL_IS_FUNCTION(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_FUNCTION)
#define HCL_IS_BLOCK(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_BLOCK)
#define HCL_IS_CLASS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CLASS)
#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_CONCODED(hcl,v,concode) (HCL_IS_CONS(hcl,v) && HCL_OBJ_GET_FLAGS_SYNCODE(v) == (concode))
@ -2444,7 +2450,9 @@ HCL_EXPORT hcl_oop_t hcl_makeclass (
hcl_t* hcl,
hcl_oop_t superclass,
hcl_ooi_t nivars,
hcl_ooi_t ncvars
hcl_ooi_t ncvars,
hcl_oop_t ivars_str,
hcl_oop_t cvars_str
);
HCL_EXPORT void hcl_freengcobj (

9
lib/obj.c
View File

@ -353,20 +353,21 @@ hcl_oop_t hcl_makefpdec (hcl_t* hcl, hcl_oop_t value, hcl_ooi_t scale)
return (hcl_oop_t)f;
}
hcl_oop_t hcl_makeclass (hcl_t* hcl, hcl_oop_t superclass, hcl_ooi_t nivars, hcl_ooi_t ncvars)
hcl_oop_t hcl_makeclass (hcl_t* hcl, hcl_oop_t superclass, hcl_ooi_t nivars, hcl_ooi_t ncvars, hcl_oop_t ivars_str, hcl_oop_t cvars_str)
{
hcl_oop_class_t c;
hcl_pushvolat (hcl, &superclass);
hcl_pushvolat (hcl, &ivars_str);
hcl_pushvolat (hcl, &cvars_str);
c = (hcl_oop_class_t)hcl_allocoopobj(hcl, HCL_BRAND_CLASS, HCL_CLASS_NAMED_INSTVARS);
hcl_popvolat (hcl);
hcl_popvolats (hcl, 3);
if (HCL_UNLIKELY(!c)) return HCL_NULL;
c->superclass = superclass;
c->nivars = HCL_SMOOI_TO_OOP(nivars);
c->ncvars = HCL_SMOOI_TO_OOP(ncvars);
return (hcl_oop_t)c;
}
@ -458,7 +459,9 @@ hcl_oop_t hcl_instantiate (hcl_t*hcl, hcl_oop_class_t _class, const void* vptr,
if (HCL_LIKELY(oop))
{
#if 0
hcl_ooi_t spec;
#endif
HCL_OBJ_SET_CLASS (oop, (hcl_oop_t)_class);
#if 0
spec = HCL_OOP_TO_SMOOI(_class->spec);