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

added vm code to apply the attribute list encoded in the CLASS_ENTER instruction
All checks were successful
continuous-integration/drone/push Build is passing
Details

Browse Source
This commit is contained in:
hyung-hwan 2024-10-06 00:18:24 +09:00
parent 2c89b2ae97
commit 54e33f53b9
9 changed files with 39 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
lib/comp.c
View File

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

1
lib/err.c
View File

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

28
lib/exec.c
View File

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

5
lib/hcl.h
View File

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

9
lib/obj.c
View File

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

1
lib/read.c
View File

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

2
t/call-5001.err
View File

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

10
t/class-5001.err
View File

@ -216,11 +216,10 @@ 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 { ##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"
}

4
t/err.sh
View File

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