updated compiler to prohibit redefinition of a named class

lib/comp.c

@@ -2588,9 +2588,7 @@ static int compile_class (hcl_t* hcl, hcl_cnode_t* src, int defclass)
 			return -1;
 		}
 
-	//SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, tmp); /* 1 - superclass expression */
 		nsuperclasses = 1;
-
 		obj = HCL_CNODE_CONS_CDR(obj);
 	}
 	else
@@ -2599,24 +2597,45 @@ static int compile_class (hcl_t* hcl, hcl_cnode_t* src, int defclass)
 		superclass = HCL_NULL;
 	}
 
-	if (class_name)
-		SWITCH_TOP_CFRAME (hcl, COP_COMPILE_SYMBOL_LITERAL, class_name); /* 1 - push the class name for a named class */
-	else
-		SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, &hcl->c->fake_cnode.nil); /* 1 - push nil for class name  for anonymous class */
 
-	PUSH_SUBCFRAME (hcl, COP_COMPILE_CLASS_P2, class_name); /* 3 - use class name for assignment */
+	if (class_name)
-	cf = GET_SUBCFRAME(hcl);
+	{
+		//SWITCH_TOP_CFRAME (hcl, COP_COMPILE_SYMBOL_LITERAL, class_name); /* 1 - push the class name for a named class */
+		hcl_oow_t index;
+		hcl_oop_t cons, sym;
+
+		sym = hcl_makesymbol(hcl, HCL_CNODE_GET_TOKPTR(class_name), HCL_CNODE_GET_TOKLEN(class_name));
+		if (HCL_UNLIKELY(!sym)) return -1;
+
+		cons = (hcl_oop_t)hcl_getatsysdic(hcl, sym);
+		if (!cons)
+		{
+			cons = (hcl_oop_t)hcl_putatsysdic(hcl, sym, hcl->_nil);
+			if (HCL_UNLIKELY(!cons)) return -1;
+		}
+
+		if (add_literal(hcl, cons, &index) <= -1) return -1;
+		if (emit_single_param_instruction(hcl, HCL_CODE_PUSH_LITERAL_0, index, HCL_CNODE_GET_LOC(class_name)) <= -1) return -1;
+	}
+	else
+	{
+		if (emit_byte_instruction(hcl, HCL_CODE_PUSH_NIL,HCL_CNODE_GET_LOC(cmd)) <= -1) return -1; /* push nil for class name of an anonymous class */
+	}
+	POP_CFRAME (hcl);
+
+	PUSH_CFRAME (hcl, COP_COMPILE_CLASS_P2, class_name); /* 3 - use class name for assignment */
+	cf = GET_TOP_CFRAME(hcl);
 	cf->u._class.nsuperclasses = 0; /* unsed for CLASS_P2 */
 	cf->u._class.start_loc = *HCL_CNODE_GET_LOC(src); /* TODO: use *HCL_CNODE_GET_LOC(cmd) instead? */
 	cf->u._class.cmd_cnode = cmd;
 
-	PUSH_SUBCFRAME (hcl, COP_COMPILE_CLASS_P1, obj); /* 2 - variables declaraions and actual body */
+	PUSH_CFRAME (hcl, COP_COMPILE_CLASS_P1, obj); /* 2 - variables declaraions and actual body */
-	cf = GET_SUBCFRAME(hcl);
+	cf = GET_TOP_CFRAME(hcl);
 	cf->u._class.nsuperclasses = nsuperclasses; /* this needs to change if we support multiple superclasses... */
 	cf->u._class.start_loc = *HCL_CNODE_GET_LOC(src); /* TODO: use *HCL_CNODE_GET_LOC(cmd) instead? */
 	cf->u._class.cmd_cnode = cmd;
 
-	if (superclass) PUSH_CFRAME (hcl, COP_COMPILE_OBJECT, superclass); /* 0 - superclass expression */
+	if (superclass) PUSH_CFRAME (hcl, COP_COMPILE_OBJECT, superclass); /* 1 - superclass expression */
 	return 0;
 }
 

lib/exec.c

@@ -3550,10 +3550,19 @@ static int execute (hcl_t* hcl)
 				/*ass = hcl->code.lit.arr->slot[b1];*/
 				ass = (hcl_oop_cons_t)hcl->active_function->literal_frame[b1];
 				HCL_ASSERT (hcl, HCL_IS_CONS(hcl, ass));
+				/* this association is an entry in the system dictionary.
+				 * it doesn't need to look up the dictionary for each access
+				 * as the pointer to the association is in the literal frame */
 
 				if ((bcode >> 3) & 1)
 				{
 					/* store or pop */
+					if (HCL_IS_CLASS(hcl, ass->cdr) && ((hcl_oop_class_t)ass->cdr)->name == ass->car)
+					{
+						hcl_seterrbfmt (hcl, HCL_EPERM, "prohibited redefintion of %.*js", HCL_OBJ_GET_SIZE(ass->car), HCL_OBJ_GET_CHAR_SLOT(ass->car));
+						if (do_throw_with_internal_errmsg(hcl, fetched_instruction_pointer) >= 0) break;
+						goto oops_with_errmsg_supplement;
+					}
 					ass->cdr = HCL_STACK_GETTOP(hcl);
 
 					if ((bcode >> 2) & 1)
@@ -3857,13 +3866,13 @@ static int execute (hcl_t* hcl)
 
 			case HCL_CODE_CLASS_ENTER:
 			{
-				/* push superclass
+				/* push an association with class_name as a key or push nil
-				   push class_name
+				   push superclass (only if nsuperclassses > 0)
 				   push ivars_string
 				   push cvars_string
 				   class_enter nsuperclasses nivars ncvars
 				 */
-				hcl_oop_t t, superclass, ivars_str, cvars_str, class_name;
+				hcl_oop_t t, superclass, ivars_str, cvars_str, class_name, class_name_ass;
 				hcl_oow_t b3;
 
 				FETCH_PARAM_CODE_TO (hcl, b1); /* nsuperclasses */
@@ -3886,9 +3895,6 @@ static int execute (hcl_t* hcl)
 				}
 				else ivars_str = hcl->_nil;
 
-				HCL_STACK_POP_TO(hcl, class_name);
-				HCL_ASSERT (hcl, HCL_IS_NIL(hcl, class_name) || HCL_IS_SYMBOL(hcl, class_name));
-
 				if (b1 > 0)
 				{
 					HCL_STACK_POP_TO (hcl, superclass); /* TODO: support more than 1 superclass later when the compiler supports more */
@@ -3901,14 +3907,25 @@ static int execute (hcl_t* hcl)
  				}
 				else superclass = hcl->_nil;
 
+				HCL_STACK_POP_TO(hcl, class_name_ass);
+				/*HCL_ASSERT (hcl, HCL_IS_NIL(hcl, class_name) || HCL_IS_SYMBOL(hcl, class_name));*/
+				HCL_ASSERT (hcl, HCL_IS_NIL(hcl, class_name_ass) || HCL_IS_CONS(hcl, class_name_ass));
+
 //////////////
 //hcl_logbfmt(hcl, HCL_LOG_STDERR, "class_name in class_enter 111>>>[%O]<<<\n", class_name);
-				if (HCL_IS_SYMBOL(hcl, class_name))
+				if (HCL_IS_CONS(hcl, class_name_ass))
 				{
 //hcl_logbfmt(hcl, HCL_LOG_STDERR, "class_name in class_enter >>>[%O]<<<\n", class_name);
 					/* TODO: check if the class exists.
 					 *       check if the class is a incomlete kernel class.
 					 *       if so,  .... */
+					class_name = ((hcl_oop_cons_t)(class_name_ass))->car;
+					HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, class_name));
+				}
+				else
+				{
+					/* anonymous class */
+					class_name = hcl->_nil;
 				}
 //////////////
 
@@ -4089,7 +4106,6 @@ static int execute (hcl_t* hcl)
 				if ((bcode >> 3) & 1)
 				{
 					/* store or pop */
-
 					t->slot[b1] = HCL_STACK_GETTOP(hcl);
 
 					if ((bcode >> 2) & 1)

t/insta-02.hcl

@@ -54,10 +54,7 @@ else { printf "OK:  value is %d\n" v }
 
 ## --------------------------------------------------------------
 
-class F [ j t ] {
+class X1 [ a  b c ] {
-}
-
-class X [ a  b c ] {
 	fun :* new () {
 		self.a := 20
 		return self
@@ -69,27 +66,27 @@ class X [ a  b c ] {
 		| v |
 		v := 50
 		if (t > 5) {
-			fun X:get_j() { return (((1 + t) + a) + (b + v)) }
+			fun X1:get_j() { return (((1 + t) + a) + (b + v)) }
 		} else {
-			fun X:get_j() { return ((2 * (t + a)) + (b + v)) }
+			fun X1:get_j() { return ((2 * (t + a)) + (b + v)) }
 		}
 		return self
 	}
 }
 
-fun X:get_a() {
+fun X1:get_a() {
 	return (self:getA)
 }
 
-v := ((X:new):get_a)
+v := ((X1:new):get_a)
 if (nqv? v 20) { printf "ERROR: v is not 20 - %d\n" v } \
 else { printf "OK:  value is %d\n" v }
 
-v := (((X:new):make 5 6 7):get_j)
+v := (((X1:new):make 5 6 7):get_j)
 if (nqv? v 79) { printf "ERROR: v is not 79 - %d\n" v } \
 else { printf "OK:  value is %d\n" v }
 
-v := (((X:new):make 6 6 7):get_j)
+v := (((X1:new):make 6 6 7):get_j)
 if (nqv? v 70) { printf "ERROR: v is not 70 - %d\n" v } \
 else { printf "OK:  value is %d\n" v }
 
@@ -98,7 +95,7 @@ else { printf "OK:  value is %d\n" v }
 class F [ j t ] {
 }
 
-class X [ a b c ] {
+class X2 [ a b c ] {
 	fun :* new () {
 		| j |
 		self.a := 20
@@ -108,33 +105,33 @@ class X [ a b c ] {
 	}
 }
 
-X:new
+X2:new
 v := (F:get_x)
 if (nqv? v 1600) { printf "ERROR: v is not 1600 - %d\n" v } \
 else { printf "OK: value is %d\n" v }
 
 ## --------------------------------------------------------------
-class X {
+class X3 {
 	fun :* new (a b) {
-		fun X:sum() { return (fun(j) { return (j + (a + b)) }) }
+		fun X3:sum() { return (fun(j) { return (j + (a + b)) }) }
 		return self;
 	}
 }
 
-v := (((X:new 10 2):sum) 23)
+v := (((X3:new 10 2):sum) 23)
 if (nqv? v 35) { printf "ERROR: v is not 35 - %d\n" v } \
 else { printf "OK: value is %d\n" v }
 
 ## --------------------------------------------------------------
-class X {
+class X4 {
 	fun :: t() {
-		| X |
+		| X4 |
-		class X { ## this X isn't the local variable X
+		class X4 { ## this X4 isn't the local variable X4
 			fun :: t() {
-				X := (class {
+				X4 := (class {
 					fun :: t() {
-						| X |
+						| X4 |
-						X := (class { ## this X is the local variable X
+						X4 := (class { ## this X4 is the local variable X4
 							fun :: t() { return 60 }
 						})
 						return 40
@@ -147,18 +144,18 @@ class X {
 	}
 }
 
-v := (X:t)
+v := (X4:t)
 if (nqv? v 30) { printf "ERROR: v is not 30 - %d\n" v } \
 else { printf "OK: value is %d\n" v }
 
-v := (X:t)
+v := (X4:t)
 if (nqv? v 20) { printf "ERROR: v is not 20 - %d\n" v } \
 else { printf "OK: value is %d\n" v }
 
-v := (X:t)
+v := (X4:t)
 if (nqv? v 40) { printf "ERROR: v is not 40 - %d\n" v } \
 else { printf "OK: value is %d\n" v }
 
-v := (X:t)
+v := (X4:t)
 if (nqv? v 40) { printf "ERROR: v is not 40 - %d\n" v } \
 else { printf "OK: value is %d\n" v }