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

updating internal class representation
All checks were successful
continuous-integration/drone/push Build is passing
Details

Browse Source
This commit is contained in:
hyung-hwan 2024-07-23 23:50:29 +09:00
parent 768378a940
commit dfc6ec94f4
8 changed files with 110 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

83
lib/exec.c
View File

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

12
lib/gc.c
View File

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

4
lib/hcl-prv.h
View File

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

4
lib/hcl.h
View File

@ -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 */

37
lib/obj.c
View File

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

6
mod/core.c
View File

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

45
src/kernel.hcl
View File

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

4
t/insta-02.hcl
View File

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