From 6b476b5c6e39dbb1ba135d29d43d39d47e874cc9 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Sun, 27 Jun 2021 17:47:51 +0000 Subject: [PATCH] more code to implement class --- lib/comp.c | 624 +++++++++++++++++++++----------------------------- lib/exec.c | 37 ++- lib/hcl-prv.h | 3 + lib/hcl.h | 10 +- lib/obj.c | 9 +- 5 files changed, 302 insertions(+), 381 deletions(-) diff --git a/lib/comp.c b/lib/comp.c index 7904cc7..a375058 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -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, 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,10 +1812,7 @@ 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 | ::: x y z | ; class variables <--- how to initialize the class variables??? @@ -1737,156 +1838,7 @@ 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 */ @@ -4762,7 +4644,7 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags) HCL_ASSERT (hcl, hcl->c->fnblk.depth == -1); } - hcl ->log.default_type_mask = log_default_type_mask; + hcl->log.default_type_mask = log_default_type_mask; return 0; oops: @@ -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; } diff --git a/lib/exec.c b/lib/exec.c index 021c79a..20b4881 100644 --- a/lib/exec.c +++ b/lib/exec.c @@ -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; } diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index c767868..8a02163 100644 --- a/lib/hcl-prv.h +++ b/lib/hcl-prv.h @@ -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; diff --git a/lib/hcl.h b/lib/hcl.h index c4a5846..2f109b0 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -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 ( diff --git a/lib/obj.c b/lib/obj.c index 7ee2c63..fae512c 100644 --- a/lib/obj.c +++ b/lib/obj.c @@ -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);