From 54e33f53b9431fa38e5aa2b609bbbe34bbd0d920 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Sun, 6 Oct 2024 00:18:24 +0900 Subject: [PATCH] added vm code to apply the attribute list encoded in the CLASS_ENTER instruction --- lib/comp.c | 12 +++++++++--- lib/err.c | 1 - lib/exec.c | 28 ++++++++++++++-------------- lib/hcl.h | 5 ++--- lib/obj.c | 9 ++------- lib/read.c | 1 + t/call-5001.err | 2 +- t/class-5001.err | 12 ++++++++---- t/err.sh | 4 ++-- 9 files changed, 39 insertions(+), 35 deletions(-) diff --git a/lib/comp.c b/lib/comp.c index 03d2d8e..c782f90 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -2646,17 +2646,21 @@ static int compile_class (hcl_t* hcl, hcl_cnode_t* src) HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(obj)); tmp = HCL_CNODE_CONS_CAR(obj); - if (HCL_CNODE_IS_ELIST_CONCODED(tmp, HCL_CONCODE_XLIST) || HCL_CNODE_IS_CONS_CONCODED(tmp, HCL_CONCODE_XLIST)) + if (HCL_CNODE_IS_ELIST_CONCODED(tmp, HCL_CONCODE_XLIST) || + HCL_CNODE_IS_CONS_CONCODED(tmp, HCL_CONCODE_XLIST)) { attr_list = tmp; - obj = HCL_CNODE_CONS_CAR(obj) ; + obj = HCL_CNODE_CONS_CDR(obj); } + else goto check_class_name; /* for optimzation. it still works without this jump */ } if (obj) { HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(obj)); + tmp = HCL_CNODE_CONS_CAR(obj); + check_class_name: if (HCL_CNODE_IS_FOR_DATA_SIMPLE(tmp) || HCL_CNODE_IS_FOR_LANG(tmp)) { if (!HCL_CNODE_IS_SYMBOL_IDENT(tmp)) @@ -3489,7 +3493,9 @@ static int compile_fun (hcl_t* hcl, hcl_cnode_t* src) HCL_ASSERT (hcl, nargs + nrvars + nlvars == hcl->c->tv.wcount - saved_tv_wcount); - if (push_fnblk(hcl, HCL_CNODE_GET_LOC(src), va, nargs, nrvars, nlvars, hcl->c->tv.wcount, hcl->c->tv.s.len, hcl->code.bc.len, hcl->code.lit.len, fun_type) <= -1) return -1; + if (push_fnblk( + hcl, HCL_CNODE_GET_LOC(src), va, nargs, nrvars, nlvars, hcl->c->tv.wcount, + hcl->c->tv.s.len, hcl->code.bc.len, hcl->code.lit.len, fun_type) <= -1) return -1; if (hcl->option.trait & HCL_TRAIT_INTERACTIVE) { diff --git a/lib/err.c b/lib/err.c index 63bdba3..3570beb 100644 --- a/lib/err.c +++ b/lib/err.c @@ -102,7 +102,6 @@ static const char* synerrstr[] = "wrong character literal", "wrong string literal", "wrong symbol literal", - "invalid hashed literal", "invalid numeric literal", "out of integer range", "wrong error literal", diff --git a/lib/exec.c b/lib/exec.c index fc6b40d..3dd71ad 100644 --- a/lib/exec.c +++ b/lib/exec.c @@ -4034,8 +4034,8 @@ static int execute (hcl_t* hcl) push cvars_string class_enter indexed_type nsuperclasses nivars ncvars */ - hcl_oop_t superclass, ivars_str, cvars_str, class_name; - hcl_oop_t v; + hcl_oop_t superclass, ivars_str, cvars_str, class_name, v; + hcl_ooi_t expected_spec, expected_selfspec; hcl_oop_class_t class_obj; hcl_oow_t b0, b3; @@ -4072,16 +4072,18 @@ static int execute (hcl_t* hcl) } else superclass = hcl->_nil; - HCL_STACK_POP_TO(hcl, v); + expected_spec = HCL_CLASS_SPEC_MAKE(b2, (b0 >> 4), b0 & 0x0F); + expected_selfspec = HCL_CLASS_SELFSPEC_MAKE(b3, 0, 0); + HCL_STACK_POP_TO(hcl, v); if (HCL_IS_CONS(hcl, v)) { - /* named class. the compiler generates code to push a pair holding - * a name and a class object for a name class. */ - class_name = ((hcl_oop_cons_t)v)->car; + /* named class. the compiler generates code to push a pair + * holding a name and a class object for a name class. */ + class_name = HCL_CONS_CAR(v); HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, class_name)); - class_obj = (hcl_oop_class_t)((hcl_oop_cons_t)v)->cdr; + class_obj = (hcl_oop_class_t)HCL_CONS_CDR(v); if (HCL_IS_CLASS(hcl, class_obj)) { /* the existing value must be a class. disallow re-definition */ @@ -4091,21 +4093,18 @@ static int execute (hcl_t* hcl) { /* check if the new definition is compatible with kernel definition */ hcl_ooi_t spec, selfspec, nivars_super, nivars_super_real; - hcl_obj_type_t indexed_type; spec = HCL_OOP_TO_SMOOI(class_obj->spec); selfspec = HCL_OOP_TO_SMOOI(class_obj->selfspec); nivars_super = HCL_OOP_TO_SMOOI(class_obj->nivars_super); nivars_super_real = HCL_IS_NIL(hcl, superclass)? 0: HCL_OOP_TO_SMOOI(((hcl_oop_class_t)superclass)->nivars_super); -//if (HCL_CLASS_SPEC_IS_INDEXED(spec)) -//indexed_type = (hcl_obj_type_t)HCL_CLASS_SPEC_INDEXED_TYPE(spec); #if 0 hcl_logbfmt (hcl, HCL_LOG_STDERR, ">>>%O c->sc=%O sc=%O b2=%d b3=%d nivars=%d ncvars=%d<<<\n", class_obj, class_obj->superclass, superclass, b2, b3, (int)HCL_CLASS_SPEC_NAMED_INSTVARS(spec), (int)HCL_CLASS_SELFSPEC_CLASSVARS(spec)); #endif if (class_obj->superclass != superclass || - HCL_CLASS_SPEC_NAMED_INSTVARS(spec) != b2 || - HCL_CLASS_SELFSPEC_CLASSVARS(selfspec) != b3 || + expected_spec != spec || + expected_selfspec != selfspec || nivars_super != nivars_super_real) { hcl_seterrbfmt (hcl, HCL_EPERM, "incompatible redefintion of %.*js", HCL_OBJ_GET_SIZE(class_name), HCL_OBJ_GET_CHAR_SLOT(class_name)); @@ -4133,11 +4132,12 @@ hcl_logbfmt (hcl, HCL_LOG_STDERR, ">>>%O c->sc=%O sc=%O b2=%d b3=%d nivars=%d nc class_name = hcl->_nil; make_class: - class_obj = (hcl_oop_class_t)hcl_makeclass(hcl, class_name, superclass, b2, b3, ivars_str, cvars_str); + class_obj = (hcl_oop_class_t)hcl_makeclass(hcl, class_name, superclass, expected_spec, expected_selfspec, ivars_str, cvars_str); if (HCL_UNLIKELY(!class_obj)) goto oops_with_errmsg_supplement; } - /* push the class created to the class stack. but don't push to the normal operation stack */ + /* push the class created to the class stack. + * but don't push to the normal operation stack */ HCL_CLSTACK_PUSH (hcl, (hcl_oop_t)class_obj); break; } diff --git a/lib/hcl.h b/lib/hcl.h index 587fe16..1dcb935 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -106,7 +106,6 @@ enum hcl_synerrnum_t HCL_SYNERR_CHARLIT, /* wrong character literal */ HCL_SYNERR_STRLIT, /* wrong string literal */ HCL_SYNERR_SYMLIT, /* wrong symbol literal */ - HCL_SYNERR_HASHLIT, /* wrong hashed literal */ HCL_SYNERR_NUMLIT , /* invalid numeric literal */ HCL_SYNERR_NUMRANGE, /* number range error */ HCL_SYNERR_ERRLIT, /* wrong error literal */ @@ -2872,8 +2871,8 @@ HCL_EXPORT hcl_oop_t hcl_makeclass ( hcl_t* hcl, hcl_oop_t name, hcl_oop_t superclass, - hcl_ooi_t nivars, - hcl_ooi_t ncvars, + hcl_ooi_t spec, + hcl_ooi_t selfspec, hcl_oop_t ivars_str, hcl_oop_t cvars_str ); diff --git a/lib/obj.c b/lib/obj.c index 5b6c0b8..1d3be27 100644 --- a/lib/obj.c +++ b/lib/obj.c @@ -466,7 +466,7 @@ 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 class_name, hcl_oop_t superclass, hcl_ooi_t nivars, hcl_ooi_t ncvars, hcl_oop_t ivars_str, hcl_oop_t cvars_str) +hcl_oop_t hcl_makeclass (hcl_t* hcl, hcl_oop_t class_name, hcl_oop_t superclass, hcl_ooi_t spec, hcl_ooi_t selfspec, hcl_oop_t ivars_str, hcl_oop_t cvars_str) { hcl_oop_class_t c; @@ -474,7 +474,7 @@ hcl_oop_t hcl_makeclass (hcl_t* hcl, hcl_oop_t class_name, hcl_oop_t superclass, hcl_pushvolat (hcl, &superclass); hcl_pushvolat (hcl, &ivars_str); hcl_pushvolat (hcl, &cvars_str); - c = (hcl_oop_class_t)hcl_instantiate(hcl, hcl->c_class, HCL_NULL, ncvars); + c = (hcl_oop_class_t)hcl_instantiate(hcl, hcl->c_class, HCL_NULL, HCL_CLASS_SELFSPEC_CLASSVARS(selfspec)); hcl_popvolats (hcl, 4); if (HCL_UNLIKELY(!c)) { @@ -484,13 +484,8 @@ hcl_oop_t hcl_makeclass (hcl_t* hcl, hcl_oop_t class_name, hcl_oop_t superclass, } else { - hcl_oow_t spec, selfspec; hcl_ooi_t nivars_super; - /* TODO: other flags... indexable? byte? word?*/ - spec = HCL_CLASS_SPEC_MAKE(nivars, 0, 0); /* TODO: how to include nivars_super ? */ - selfspec = HCL_CLASS_SELFSPEC_MAKE(ncvars, 0, 0); - if (!HCL_IS_NIL(hcl, superclass)) { hcl_ooi_t superspec; diff --git a/lib/read.c b/lib/read.c index 06a8173..4b2186d 100644 --- a/lib/read.c +++ b/lib/read.c @@ -2649,6 +2649,7 @@ static int flx_hmarked_token (hcl_t* hcl, hcl_ooci_t c) /* --------------------------- */ default: init_flx_hi (FLX_HI(hcl)); + reset_flx_token (hcl); /* to discard the leading '#' */ FEED_CONTINUE (hcl, HCL_FLX_HMARKED_IDENT); goto not_consumed; } diff --git a/t/call-5001.err b/t/call-5001.err index 58f5d08..6b4cc0b 100644 --- a/t/call-5001.err +++ b/t/call-5001.err @@ -104,4 +104,4 @@ core.basicAtPut "xbcdefghiklmnl" 4 k ##ERROR: exception not handled - "receiver --- k := (core.basicAt #abcdefg 1) -core.basicAtPut #xbcdefghiklmnl 4 k ##ERROR: exception not handled - "receiver immutable - #xbcdefghiklmnl" +core.basicAtPut #xbcdefghiklmnl 4 k ##ERROR: exception not handled - "receiver immutable - xbcdefghiklmnl" diff --git a/t/class-5001.err b/t/class-5001.err index 7976aa5..00577bf 100644 --- a/t/class-5001.err +++ b/t/class-5001.err @@ -216,13 +216,12 @@ F := (class { ##ERROR: exception not handled - "prohibited redefintion of F" F := (class { }) -F := (class F { ##ERROR: exception not handle - "prohibited redefintion of F" +F := (class F { ##ERROR: exception not handled - "prohibited redefintion of F" }) -## TDOO: do we need to allow the above? - +## TDOO: do we need to allow this? ##F := 30 -##class F { ##ERROR: exception not handled - "prohibited redefintion of F" +##class F { ##E R R O R: exception not handled - "prohibited redefintion of F" ##} @@ -244,3 +243,8 @@ X11 := (class:X10 { class X11 { ##ERROR: exception not handled - "prohibited redefintion of X11" } + +--- + +class String { ##ERROR: exception not handled - "incompatible redefintion of String" +} diff --git a/t/err.sh b/t/err.sh index 8c07065..3be60e1 100644 --- a/t/err.sh +++ b/t/err.sh @@ -25,7 +25,7 @@ run_partfile() { l_expected_errinfo=$(grep -n -o -E "##ERROR: .+" "$l_partfile" 2>/dev/null) [ -z "$l_expected_errinfo" ] && { - echo "ERROR: INVALID TESTER - $l_script($l_partno) contains no ERROR information" + echo "ERROR: INVALID TESTER - $l_script(part=$l_partno,line=$l_l_partstartlineno) contains no ERROR information" return 1 } @@ -82,7 +82,7 @@ do done < "$script" [ $partlines -gt 0 ] && { - run_partfile "$@" "$partno" "$artstartlineno" "$partfile" || ever_failed=1 + run_partfile "$@" "$partno" "$partstartlineno" "$partfile" || ever_failed=1 } rm -f "$partfile"