updating internal class representation

lib/exec.c

@@ -425,7 +425,7 @@ static HCL_INLINE hcl_oop_block_t make_block (hcl_t* hcl)
 {
 	/* create a base block used for creation of a block context */
 	/*return (hcl_oop_block_t)hcl_allocoopobj(hcl, HCL_BRAND_BLOCK, HCL_BLOCK_NAMED_INSTVARS);*/
-	return (hcl_oop_function_t)hcl_instantiate(hcl, hcl->c_block, HCL_NULL, 0);
+	return (hcl_oop_block_t)hcl_instantiate(hcl, hcl->c_block, HCL_NULL, 0);
 }
 
 static HCL_INLINE void fill_block_data (hcl_t* hcl, hcl_oop_block_t blk, hcl_ooi_t attr_mask, hcl_ooi_t ip, hcl_oop_context_t homectx)
@@ -2141,11 +2141,11 @@ static HCL_INLINE int call_primitive (hcl_t* hcl, hcl_ooi_t nargs)
 
 /* ------------------------------------------------------------------------- */
 
-static hcl_oop_block_t find_imethod_in_class_noseterr (hcl_t* hcl, hcl_oop_class_t class_, hcl_oocs_t* name, hcl_ooi_t* ivaroff, hcl_oop_class_t* owner)
+static hcl_oop_block_t find_imethod_in_class_noseterr (hcl_t* hcl, hcl_oop_class_t _class, hcl_oocs_t* name, hcl_ooi_t* ivaroff, hcl_oop_class_t* owner)
 {
 	hcl_oop_t dic;
 
-	dic = class_->mdic;
+	dic = _class->mdic;
 	HCL_ASSERT (hcl, HCL_IS_NIL(hcl, dic) || HCL_IS_DIC(hcl, dic));
 
 	if (HCL_LIKELY(!HCL_IS_NIL(hcl, dic)))
@@ -2160,8 +2160,8 @@ static hcl_oop_block_t find_imethod_in_class_noseterr (hcl_t* hcl, hcl_oop_class
 			if (!HCL_IS_NIL(hcl, HCL_CONS_CDR(val)))
 			{
 				/* TODO: further check if it's a method block? */
-				*owner = class_;
+				*owner = _class;
-				*ivaroff = HCL_OOP_TO_SMOOI(class_->nivars_super);
+				*ivaroff = HCL_OOP_TO_SMOOI(_class->nivars_super);
 				return (hcl_oop_block_t)HCL_CONS_CDR(val); /* car - class method, cdr - instance method */
 			}
 		}
@@ -2263,7 +2263,7 @@ static hcl_oop_block_t find_cmethod_noseterr (hcl_t* hcl, hcl_oop_class_t _class
 
 	/* find the instance method of the Class class as a class is an instance of the Class class. */
 	/* TODO: may need to traverse up if Class is a subclass in some other Clss-related abstraction... */
-	return find_imethod_in_class_noseterr(hcl, HCL_CLASSOF(hcl, _class), &name, ivaroff, owner);
+	return find_imethod_in_class_noseterr(hcl, (hcl_oop_class_t)HCL_CLASSOF(hcl, _class), &name, ivaroff, owner);
 }
 
 static HCL_INLINE int send_message (hcl_t* hcl, hcl_oop_t rcv, hcl_oop_t msg, int to_super, hcl_ooi_t nargs, hcl_ooi_t nrvars)
@@ -3556,17 +3556,21 @@ static int execute (hcl_t* hcl)
 
 				if ((bcode >> 3) & 1)
 				{
+					hcl_oop_t v;
+
 					/* store or pop */
-					if (HCL_IS_CLASS(hcl, ass->cdr) && ((hcl_oop_class_t)ass->cdr)->name == ass->car)
+					v = HCL_STACK_GETTOP(hcl);
+					if (HCL_IS_CLASS(hcl, ass->cdr) && ((hcl_oop_class_t)ass->cdr)->name == ass->car && v != ass->cdr)
 					{
-						/* the existing value must be a class. disallow re-definition */
+						/* the existing value is a class.
+						 * the class name is the same as the key value of the pair.
+						 * disallow re-definition if the new value is not itself. */
 						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);
+					ass->cdr = v; /* update the value */
-
 					if ((bcode >> 2) & 1)
 					{
 						/* pop */
@@ -3874,7 +3878,9 @@ static int execute (hcl_t* hcl)
 				   push cvars_string
 				   class_enter nsuperclasses nivars ncvars
 				 */
-				hcl_oop_t t, superclass, ivars_str, cvars_str, class_name, class_name_ass;
+				hcl_oop_t superclass, ivars_str, cvars_str, class_name;
+				hcl_oop_t v;
+				hcl_oop_class_t class_obj;
 				hcl_oow_t b3;
 
 				FETCH_PARAM_CODE_TO (hcl, b1); /* nsuperclasses */
@@ -3909,33 +3915,60 @@ static int execute (hcl_t* hcl)
  				}
 				else superclass = hcl->_nil;
 
-				HCL_STACK_POP_TO(hcl, class_name_ass);
+				HCL_STACK_POP_TO(hcl, v);
-				/*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_CONS(hcl, v))
-				if (HCL_IS_CONS(hcl, class_name_ass))
 				{
-//hcl_logbfmt(hcl, HCL_LOG_STDERR, "class_name in class_enter >>>[%O]<<<\n", class_name);
+					/* named class. the compiler generates code to push a pair holding
-					/* TODO: check if the class exists.
+					 * a name and a class object for a name class. */
-					 *       check if the class is a incomlete kernel class.
+					class_name = ((hcl_oop_cons_t)v)->car;
-					 *       if so,  .... */
-					class_name = ((hcl_oop_cons_t)(class_name_ass))->car;
 					HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, class_name));
+
+					class_obj = (hcl_oop_class_t)((hcl_oop_cons_t)v)->cdr;
+					if (HCL_IS_CLASS(hcl, class_obj))
+					{
+						/* the existing value must be a class. disallow re-definition */
+
+						/* 0(non-kernel object), 1(incomplete kernel object), 2(complete kernel object) */
+						if (HCL_OBJ_GET_FLAGS_KERNEL(class_obj) == 1)
+						{
+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_OOP_TO_SMOOI(class_obj->nivars), (int)HCL_OOP_TO_SMOOI(class_obj->ncvars));
+							/* check if the new definition is compatible with kernel definition */
+							if (class_obj->superclass != superclass || HCL_OOP_TO_SMOOI(class_obj->nivars) != b2 || HCL_OOP_TO_SMOOI(class_obj->ncvars) != b3)
+							{
+								hcl_seterrbfmt (hcl, HCL_EPERM, "incompatible redefintion of %.*js", HCL_OBJ_GET_SIZE(class_name), HCL_OBJ_GET_CHAR_SLOT(class_name));
+								if (do_throw_with_internal_errmsg(hcl, fetched_instruction_pointer) >= 0) break;
+								goto oops_with_errmsg_supplement;
+							}
+						}
+						else
+						{
+							hcl_seterrbfmt (hcl, HCL_EPERM, "prohibited redefintion of %.*js", HCL_OBJ_GET_SIZE(class_name), HCL_OBJ_GET_CHAR_SLOT(class_name));
+							if (do_throw_with_internal_errmsg(hcl, fetched_instruction_pointer) >= 0) break;
+							goto oops_with_errmsg_supplement;
+						}
+					}
+					else
+					{
+						HCL_ASSERT (hcl, HCL_IS_NIL(hcl, (hcl_oop_t)class_obj));
+						goto make_class;
+					}
 				}
 				else
 				{
 					/* anonymous class */
+					HCL_ASSERT (hcl, HCL_IS_NIL(hcl, v));
 					class_name = hcl->_nil;
+
+				make_class:
+					class_obj = (hcl_oop_class_t)hcl_makeclass(hcl, class_name, superclass, b2, b3, ivars_str, cvars_str);
+					if (HCL_UNLIKELY(!class_obj)) goto oops_with_errmsg_supplement;
 				}
 //////////////
 
-				t = hcl_makeclass(hcl, class_name, superclass, b2, b3, ivars_str, cvars_str); /* TOOD: pass variable information... */
-				if (HCL_UNLIKELY(!t)) goto oops_with_errmsg_supplement;
-
 				/* push the class created to the class stack. but don't push to the normal operation stack */
-				HCL_CLSTACK_PUSH (hcl, t);
+				HCL_CLSTACK_PUSH (hcl, (hcl_oop_t)class_obj);
 				break;
 			}
 

lib/gc.c

@@ -1183,7 +1183,11 @@ static hcl_oop_class_t alloc_kernel_class (hcl_t* hcl, int class_flags, hcl_oow_
 	HCL_OBJ_SET_CLASS (c, (hcl_oop_t)hcl->c_class);
 	c->spec = HCL_SMOOI_TO_OOP(spec);
 	c->selfspec = HCL_SMOOI_TO_OOP(HCL_CLASS_SELFSPEC_MAKE(num_classvars, 0, class_flags));
-	c->nivars = HCL_SMOOI_TO_OOP(0); /* TODO: encode it into spec? */
+
+/* TODO: remove the following two duplicate fields with the spec fields */
+	c->nivars = HCL_SMOOI_TO_OOP(HCL_CLASS_SPEC_NAMED_INSTVARS(spec));
+	//c->nivars = HCL_SMOOI_TO_OOP(0);
+	c->ncvars = HCL_SMOOI_TO_OOP(num_classvars);
 	c->nivars_super = HCL_SMOOI_TO_OOP(0); /* TODO: encode it into spec? */
 	c->ibrand = HCL_SMOOI_TO_OOP(ibrand);
 
@@ -1210,7 +1214,8 @@ static int ignite_1 (hcl_t* hcl)
 	if (HCL_LIKELY(!hcl->c_class))
 	{
 		hcl->c_class = alloc_kernel_class(
-			hcl, kernel_classes[KCI_CLASS].class_flags,
+			hcl,
+			kernel_classes[KCI_CLASS].class_flags,
 			kernel_classes[KCI_CLASS].class_num_classvars,
 			HCL_CLASS_SPEC_MAKE(kernel_classes[KCI_CLASS].class_spec_named_instvars,
 			                    kernel_classes[KCI_CLASS].class_spec_flags,
@@ -1234,7 +1239,8 @@ static int ignite_1 (hcl_t* hcl)
 		if (i == KCI_CLASS) continue; /* skip Class as it's created above */
 
 		tmp = alloc_kernel_class(
-			hcl, kernel_classes[i].class_flags,
+			hcl,
+			kernel_classes[i].class_flags,
 			kernel_classes[i].class_num_classvars,
 			HCL_CLASS_SPEC_MAKE(kernel_classes[i].class_spec_named_instvars,
 			                    kernel_classes[i].class_spec_flags,

lib/hcl-prv.h

@@ -223,8 +223,8 @@
  * the spec field of the class with limited number of bits assigned to
  * the number of named instance variables.
  */
-#define HCL_MAX_NAMED_INSTVARS \
+#define HCL_CLASS_SPEC_INSTVAR_BITS (HCL_SMOOI_ABS_BITS - (HCL_OBJ_FLAGS_TYPE_BITS + HCL_CLASS_SPEC_FLAG_BITS))
-	HCL_BITS_MAX(hcl_oow_t, HCL_SMOOI_ABS_BITS - (HCL_OBJ_FLAGS_TYPE_BITS + HCL_CLASS_SPEC_FLAG_BITS))
+#define HCL_MAX_NAMED_INSTVARS HCL_BITS_MAX(hcl_oow_t, HCL_CLASS_SPEC_INSTVAR_BITS)
 
 /* Given the number of named instance variables, what is the maximum number
  * of indexed instance variables? The number of indexed instance variables

lib/hcl.h

@@ -585,8 +585,6 @@ typedef struct hcl_block_t* hcl_oop_block_t;
 typedef struct hcl_context_t hcl_context_t;
 typedef struct hcl_context_t* hcl_oop_context_t;
 
-#define HCL_CALL_FLAG_VA (1 << 0)
-
 struct hcl_function_t
 {
 	HCL_OBJ_HEADER;
@@ -1785,7 +1783,7 @@ struct hcl_t
 	 * because the 2 high extended bits are used only if the low tag bits
 	 * are 3 */
 	int tagged_brands[16];
-	hcl_oop_class_t* tagged_classes[16];
+	hcl_oop_class_t* tagged_classes[16]; /* this is a pointer to hcl_oop_class_t which is also a pointer */
 
 
 	hcl_oop_t* volat_stack[256]; /* stack for temporaries */

lib/obj.c

@@ -464,6 +464,8 @@ hcl_oop_t hcl_makefpdec (hcl_t* hcl, hcl_oop_t value, hcl_ooi_t scale)
 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_class_t c;
+	hcl_oow_t spec, selfspec;
+	hcl_ooi_t nivars_super;
 
 	hcl_pushvolat (hcl, &class_name);
 	hcl_pushvolat (hcl, &superclass);
@@ -483,24 +485,19 @@ hcl_oop_t hcl_makeclass (hcl_t* hcl, hcl_oop_t class_name, hcl_oop_t superclass,
 	}
 	HCL_OBJ_SET_CLASS (c, (hcl_oop_t)hcl->c_class);
 
-	c->spec = HCL_SMOOI_TO_OOP(0); /* TODO: fix this - encode nivars and nivars_super to spec??? */
+	/* TODO: other flags... indexable? byte? word?*/
-	c->selfspec = HCL_SMOOI_TO_OOP(0); /* TODO: fix  this - encode ncvars to selfspec??? */
+	spec = HCL_CLASS_SPEC_MAKE(nivars, 0, 0); /* TODO: how to include nivars_super ? */
+	selfspec = HCL_CLASS_SELFSPEC_MAKE(ncvars, 0, 0);
+	nivars_super = HCL_IS_NIL(hcl, superclass)? 0: HCL_OOP_TO_SMOOI(((hcl_oop_class_t)superclass)->nivars_super) + HCL_OOP_TO_SMOOI(((hcl_oop_class_t)superclass)->nivars);
+
+	c->spec = HCL_SMOOI_TO_OOP(spec);
+	c->selfspec = HCL_SMOOI_TO_OOP(selfspec);
 	c->name = class_name;
 	c->superclass = superclass;
 	c->nivars = HCL_SMOOI_TO_OOP(nivars);
 	c->ncvars = HCL_SMOOI_TO_OOP(ncvars);
-	c->ibrand = HCL_SMOOI_TO_OOP(HCL_BRAND_INSTANCE); /* TODO: really need ibrand??? */
-
-	if ((hcl_oop_t)superclass != hcl->_nil)
-	{
-		hcl_ooi_t nivars_super;
-		nivars_super = HCL_OOP_TO_SMOOI(((hcl_oop_class_t)superclass)->nivars_super) + HCL_OOP_TO_SMOOI(((hcl_oop_class_t)superclass)->nivars);
 	c->nivars_super = HCL_SMOOI_TO_OOP(nivars_super);
-	}
+	c->ibrand = HCL_SMOOI_TO_OOP(HCL_BRAND_INSTANCE); /* TODO: really need ibrand??? */
-	else
-	{
-		c->nivars_super = HCL_SMOOI_TO_OOP(0);
-	}
 
 	/* TODO: remember ivars_str and vars_str? */
 	/* duplicate ivars_str and cvars_str and set it to c->ivarnames and c->cvarnames???? */
@@ -508,17 +505,6 @@ hcl_oop_t hcl_makeclass (hcl_t* hcl, hcl_oop_t class_name, hcl_oop_t superclass,
 	return (hcl_oop_t)c;
 }
 
-#if 0
-static HCL_INLINE int decode_spec (hcl_t* hcl, hcl_oop_class_t _class, hcl_obj_type_t* type, hcl_oow_t* outlen)
-{
-	/* TODO: */
-
-	*type = HCL_OBJ_TYPE_OOP;
-	*outlen = HCL_OOP_TO_SMOOI(_class->nivars_super) + HCL_OOP_TO_SMOOI(_class->nivars);
-	return 0;
-}
-#else
-
 static HCL_INLINE int decode_spec (hcl_t* hcl, hcl_oop_class_t _class, hcl_oow_t num_flexi_fields, hcl_obj_type_t* type, hcl_oow_t* outlen)
 {
 	hcl_oow_t spec;
@@ -569,10 +555,9 @@ static HCL_INLINE int decode_spec (hcl_t* hcl, hcl_oop_class_t _class, hcl_oow_t
 	*type = indexed_type;
 
 	/* TODO: THIS PART IS WRONG.. nivars_super and nivars should be encoded to the spec.... */
-	*outlen = num_fixed_fields + num_flexi_fields + HCL_OOP_TO_SMOOI(_class->nivars_super) + HCL_OOP_TO_SMOOI(_class->nivars);
+	*outlen = num_fixed_fields + num_flexi_fields + HCL_OOP_TO_SMOOI(_class->nivars_super) /*+ HCL_OOP_TO_SMOOI(_class->nivars)*/;
 	return 0;
 }
-#endif
 
 hcl_oop_t hcl_instantiate (hcl_t* hcl, hcl_oop_class_t _class, const void* vptr, hcl_oow_t vlen)
 {

mod/core.c

@@ -29,9 +29,9 @@
 
 static hcl_pfrc_t pf_core_get_class_name (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
 {
-	hcl_oop_oop_t obj;
+	hcl_oop_t obj;
 
-	obj = (hcl_oop_oop_t)HCL_STACK_GETARG(hcl, nargs, 0);
+	obj = HCL_STACK_GETARG(hcl, nargs, 0);
 
 	if (!HCL_IS_CLASS(hcl, obj))
 	{
@@ -39,7 +39,7 @@ static hcl_pfrc_t pf_core_get_class_name (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t
 		hcl_seterrbfmt (hcl, HCL_EINVAL, "parameter not a class - %O", obj);
 		return HCL_PF_FAILURE;
 	#else
-		obj = (hcl_oop_oop_t)HCL_CLASSOF(hcl, obj);
+		obj = (hcl_oop_t)HCL_CLASSOF(hcl, obj);
 		HCL_ASSERT (hcl, HCL_IS_CLASS(hcl, obj));
 	#endif
 	}

src/kernel.hcl

@@ -1,19 +1,22 @@
-class Object {
+class Apex {
 }
 
-class Collection : Object {
+class Object :: Apex {
 }
 
-class IndexedCollection: Collection {
+class Collection :: Object {
 }
 
-class FixedSizedCollection: Collection {
+class IndexedCollection :: Collection {
 }
 
-class Array: FixedSizedCollection {
+class FixedSizedCollection :: Collection {
 }
 
-class String: Array {
+class Array :: FixedSizedCollection {
+}
+
+class String :: Array {
 }
 
 fun Collection:length() {
@@ -28,22 +31,22 @@ fun Class:name() {
 	return (core.class_name self)
 }
 
-class String: Array (a b c) {
+##class String:: Array [a b c] {
-}
+##}
 
-class String: Array (
+##class String:: Array [
-	monaco
+##	monaco
-	duncan
+##	duncan
-	falcon
+##	falcon
-	:deuce
+##	deuce
-	:canival
+##	canival
-	:pebble
+##	pebble
-	:godzilla
+##	godzilla
-) {
+##] {
-	fun Collection:slice(index count) {
+##	fun Collection:slice(index count) {
-		return (arr.slice self index count)
+##		return (arr.slice self index count)
-	}
+##	}
-}
+##}
 
 
 printf "string length %d\n" ("aaaa":length)

t/insta-02.hcl

@@ -27,7 +27,7 @@ else { printf "OK:  value is %d\n" v };
 
 ## --------------------------------------------------------------
 
-class X [ a b c d ] {
+class X0 [ a b c d ] {
         fun :*new() {
                 return self;
         }
@@ -44,7 +44,7 @@ class X [ a b c d ] {
 		return self.d
 	}
 
-}; a := (X:new); v := (a:x)
+}; a := (X0:new); v := (a:x)
 if (nqv? v 100) { printf "ERROR: v is not 100\n" } \
 else { printf "OK:  value is %d\n" v }