added vm code to apply the attribute list encoded in the CLASS_ENTER instruction

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

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

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 superclass, ivars_str, cvars_str, class_name, v;
-				hcl_oop_t 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
+					/* named class. the compiler generates code to push a pair
-					 * a name and a class object for a name class. */
+					 * holding a name and a class object for a name class. */
-					class_name = ((hcl_oop_cons_t)v)->car;
+					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 ||
+							    expected_spec != spec ||
-							    HCL_CLASS_SELFSPEC_CLASSVARS(selfspec) != b3 ||
+							    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;
 			}

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         spec,
-	hcl_ooi_t         ncvars,
+	hcl_ooi_t         selfspec,
 	hcl_oop_t         ivars_str,
 	hcl_oop_t         cvars_str
 );

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;

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

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"

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"
+}

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"