diff --git a/lib/exec.c b/lib/exec.c index 802cd4f..2a7ba93 100644 --- a/lib/exec.c +++ b/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_; - *ivaroff = HCL_OOP_TO_SMOOI(class_->nivars_super); + *owner = _class; + *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_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_STACK_POP_TO(hcl, v); ////////////// -//hcl_logbfmt(hcl, HCL_LOG_STDERR, "class_name in class_enter 111>>>[%O]<<<\n", class_name); - if (HCL_IS_CONS(hcl, class_name_ass)) + if (HCL_IS_CONS(hcl, v)) { -//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; + /* 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; 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; } diff --git a/lib/gc.c b/lib/gc.c index cc59d29..01e4abb 100644 --- a/lib/gc.c +++ b/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, diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index 91975ac..ccc910d 100644 --- a/lib/hcl-prv.h +++ b/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 \ - HCL_BITS_MAX(hcl_oow_t, HCL_SMOOI_ABS_BITS - (HCL_OBJ_FLAGS_TYPE_BITS + HCL_CLASS_SPEC_FLAG_BITS)) +#define HCL_CLASS_SPEC_INSTVAR_BITS (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 diff --git a/lib/hcl.h b/lib/hcl.h index ae29fec..2523279 100644 --- a/lib/hcl.h +++ b/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 */ diff --git a/lib/obj.c b/lib/obj.c index 8cb5a2e..9901b81 100644 --- a/lib/obj.c +++ b/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,42 +485,26 @@ 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??? */ - c->selfspec = HCL_SMOOI_TO_OOP(0); /* TODO: fix this - encode ncvars to selfspec??? */ + /* 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); + 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->nivars_super = HCL_SMOOI_TO_OOP(nivars_super); 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); - } - 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???? */ 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) { diff --git a/mod/core.c b/mod/core.c index f91c2da..6048f3b 100644 --- a/mod/core.c +++ b/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 } diff --git a/src/kernel.hcl b/src/kernel.hcl index 8a23999..d2c9fa6 100644 --- a/src/kernel.hcl +++ b/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 ( - monaco - duncan - falcon - :deuce - :canival - :pebble - :godzilla -) { - fun Collection:slice(index count) { - return (arr.slice self index count) - } -} +##class String:: Array [ +## monaco +## duncan +## falcon +## deuce +## canival +## pebble +## godzilla +##] { +## fun Collection:slice(index count) { +## return (arr.slice self index count) +## } +##} printf "string length %d\n" ("aaaa":length) diff --git a/t/insta-02.hcl b/t/insta-02.hcl index ea59025..e8a950f 100644 --- a/t/insta-02.hcl +++ b/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 }