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

enhanced the print function to print the class name for a class
All checks were successful
continuous-integration/drone/push Build is passing
Details

Browse Source 
enahnced the compiler to handle class defintion better.
updated method management routines into method dictionary
This commit is contained in:
hyung-hwan 2024-07-19 20:50:28 +09:00
parent 91e1e8c9c3
commit f216699240
8 changed files with 169 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
lib/comp.c
View File

@ -2497,9 +2497,10 @@ static HCL_INLINE int compile_else (hcl_t* hcl)
static int compile_class (hcl_t* hcl, hcl_cnode_t* src, int defclass) static int compile_class (hcl_t* hcl, hcl_cnode_t* src, int defclass)
{ {
hcl_cnode_t* cmd, * obj;
hcl_cnode_t* class_name;
hcl_cframe_t* cf; hcl_cframe_t* cf;
hcl_cnode_t* cmd, * obj, * tmp;
hcl_cnode_t* class_name, * superclass;
int nsuperclasses;
cmd = HCL_CNODE_CONS_CAR(src); cmd = HCL_CNODE_CONS_CAR(src);
obj = HCL_CNODE_CONS_CDR(src); obj = HCL_CNODE_CONS_CDR(src);
@ -2512,7 +2513,7 @@ static int compile_class (hcl_t* hcl, hcl_cnode_t* src, int defclass)
class_as_defclass: class_as_defclass:
if (!obj) if (!obj)
{ {
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_CNODE_GET_LOC(src), HCL_NULL, "no name in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); hcl_setsynerrbfmt (hcl, HCL_SYNERR_NAME, HCL_CNODE_GET_LOC(src), HCL_NULL, "no class name in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd));
return -1; return -1;
} }
else if (!HCL_CNODE_IS_CONS(obj)) else if (!HCL_CNODE_IS_CONS(obj))
@ -2538,8 +2539,6 @@ static int compile_class (hcl_t* hcl, hcl_cnode_t* src, int defclass)
return -1; return -1;
} }
/* TODO: check if a class name is one of the kernel classes. arrange to emit CLASS_LOAD instead of CLASS_ENTER */
obj = HCL_CNODE_CONS_CDR(obj); obj = HCL_CNODE_CONS_CDR(obj);
} }
else else
@ -2560,64 +2559,64 @@ static int compile_class (hcl_t* hcl, hcl_cnode_t* src, int defclass)
class_name = HCL_NULL; class_name = HCL_NULL;
} }
if (obj) if (!obj)
{ {
hcl_cnode_t* marker, * tmp, * dcl; hcl_setsynerrbfmt (hcl, HCL_SYNERR_BLOCK, HCL_CNODE_GET_LOC(src), HCL_NULL, "no class body", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd));
return -1;
}
marker = HCL_CNODE_CONS_CAR(obj); tmp = HCL_CNODE_CONS_CAR(obj);
if (/*!HCL_CNODE_IS_COLON(marker)*/!HCL_CNODE_IS_DBLCOLONS(marker)) goto no_superclass; if (/*HCL_CNODE_IS_COLON(tmp) || */HCL_CNODE_IS_DBLCOLONS(tmp))
{
hcl_cnode_t* marker;
tmp = obj; marker = tmp;
obj = HCL_CNODE_CONS_CDR(obj); obj = HCL_CNODE_CONS_CDR(obj);
if (!obj || !HCL_CNODE_IS_CONS(obj)) if (!obj || !HCL_CNODE_IS_CONS(obj))
{ {
hcl_setsynerrbfmt (hcl, HCL_SYNERR_EOX, HCL_CNODE_GET_LOC(tmp), HCL_NULL, "no expression or declaration after double colons"); hcl_setsynerrbfmt (hcl, HCL_SYNERR_EOX, HCL_CNODE_GET_LOC(marker), HCL_NULL,
"no expression or declaration after %.*js", HCL_CNODE_GET_TOKLEN(marker), HCL_CNODE_GET_TOKPTR(marker));
return -1; return -1;
} }
/* superclass part */ /* superclass part */
tmp = HCL_CNODE_CONS_CAR(obj); superclass = HCL_CNODE_CONS_CAR(obj);
if (!HCL_CNODE_IS_SYMBOL_PLAIN(tmp)) if (!HCL_CNODE_IS_SYMBOL_PLAIN(superclass))
{ {
hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_CNODE_GET_LOC(tmp), HCL_NULL, "no valid superclass name found after %.*js", HCL_CNODE_GET_TOKLEN(marker), HCL_CNODE_GET_TOKPTR(marker)); hcl_setsynerrbfmt (hcl, HCL_SYNERR_NAME, HCL_CNODE_GET_LOC(marker), HCL_NULL,
"no valid superclass name found after %.*js", HCL_CNODE_GET_TOKLEN(marker), HCL_CNODE_GET_TOKPTR(marker));
return -1; return -1;
} }
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, tmp); /* 1 - superclass expression */
PUSH_SUBCFRAME (hcl, COP_COMPILE_CLASS_P2, class_name); /* 4 - class name */ //SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, tmp); /* 1 - superclass expression */
cf = GET_SUBCFRAME(hcl); nsuperclasses = 1;
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;
obj = HCL_CNODE_CONS_CDR(obj); obj = HCL_CNODE_CONS_CDR(obj);
PUSH_SUBCFRAME (hcl, COP_COMPILE_CLASS_P1, obj); /* 3 - variables declaraions and actual body */
cf = GET_SUBCFRAME(hcl);
cf->u._class.nsuperclasses = 1; /* this one 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;
PUSH_SUBCFRAME (hcl, COP_COMPILE_SYMBOL_LITERAL, class_name); /* 2 - class name */
} }
else else
{ {
no_superclass: nsuperclasses = 0;
superclass = HCL_NULL;
}
if (class_name)
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_SYMBOL_LITERAL, class_name); /* 1 - push nil for class name */
else
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, &hcl->c->fake_cnode.nil); /* 1 - push nil for class name */ SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, &hcl->c->fake_cnode.nil); /* 1 - push nil for class name */
PUSH_SUBCFRAME (hcl, COP_COMPILE_CLASS_P2, class_name); /* 3 */ PUSH_SUBCFRAME (hcl, COP_COMPILE_CLASS_P2, class_name); /* 3 - use class name for assignment */
cf = GET_SUBCFRAME(hcl); cf = GET_SUBCFRAME(hcl);
cf->u._class.nsuperclasses = 0; /* unsed for CLASS_P2 */ 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.start_loc = *HCL_CNODE_GET_LOC(src); /* TODO: use *HCL_CNODE_GET_LOC(cmd) instead? */
cf->u._class.cmd_cnode = cmd; cf->u._class.cmd_cnode = cmd;
PUSH_SUBCFRAME(hcl, COP_COMPILE_CLASS_P1, obj); /* 2 */ PUSH_SUBCFRAME (hcl, COP_COMPILE_CLASS_P1, obj); /* 2 - variables declaraions and actual body */
cf = GET_TOP_CFRAME(hcl); cf = GET_SUBCFRAME(hcl);
cf->u._class.nsuperclasses = 0; /* this one needs to change if we support multiple superclasses... */ 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.start_loc = *HCL_CNODE_GET_LOC(src); /* TODO: use *HCL_CNODE_GET_LOC(cmd) instead? */
cf->u._class.cmd_cnode = cmd; cf->u._class.cmd_cnode = cmd;
}
if (superclass) PUSH_CFRAME (hcl, COP_COMPILE_OBJECT, superclass); /* 0 - superclass expression */
return 0; return 0;
} }
@ -4617,7 +4616,7 @@ static int compile_symbol_literal (hcl_t* hcl)
/* treat a symbol as a string */ /* treat a symbol as a string */
/* TODO: do i need to create a symbol literal like smalltalk? */ /* TODO: do i need to create a symbol literal like smalltalk? */
lit = hcl_makestring(hcl, HCL_CNODE_GET_TOKPTR(oprnd), HCL_CNODE_GET_TOKLEN(oprnd), 0); lit = hcl_makesymbol(hcl, HCL_CNODE_GET_TOKPTR(oprnd), HCL_CNODE_GET_TOKLEN(oprnd));
if (HCL_UNLIKELY(!lit)) return -1; if (HCL_UNLIKELY(!lit)) return -1;
if (emit_push_literal(hcl, lit, HCL_CNODE_GET_LOC(oprnd)) <= -1) return -1; if (emit_push_literal(hcl, lit, HCL_CNODE_GET_LOC(oprnd)) <= -1) return -1;

68
lib/dic.c
View File

@ -95,7 +95,7 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc)
return newbuc; return newbuc;
} }
static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key, hcl_oop_t value) static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key, hcl_oop_t value, int is_method)
{ {
hcl_ooi_t tally; hcl_ooi_t tally;
hcl_oow_t index; hcl_oow_t index;
@ -121,32 +121,41 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t k
while (dic->bucket->slot[index] != hcl->_nil) while (dic->bucket->slot[index] != hcl->_nil)
{ {
#if defined(SYMBOL_ONLY_KEY) #if defined(SYMBOL_ONLY_KEY)
ass = (hcl_oop_cons_t)dic->bucket->slot[index]; /* nothing */
HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass));
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,ass->car));
if (HCL_OBJ_GET_SIZE(key) == HCL_OBJ_GET_SIZE(ass->car) &&
hcl_equal_oochars(HCL_OBJ_GET_CHAR_SLOT(key), HCL_OBJ_GET_CHAR_SLOT(ass->car), HCL_OBJ_GET_SIZE(key)))
{
/* the value of HCL_NULL indicates no insertion or update. */
if (value) ass->cdr = value; /* update */
return ass;
}
#else #else
int n; int n;
#endif
ass = (hcl_oop_cons_t)dic->bucket->slot[index]; ass = (hcl_oop_cons_t)dic->bucket->slot[index];
HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass)); HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass));
#if defined(SYMBOL_ONLY_KEY)
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,ass->car));
if (HCL_OBJ_GET_SIZE(key) == HCL_OBJ_GET_SIZE(ass->car) &&
hcl_equal_oochars(HCL_OBJ_GET_CHAR_SLOT(key), HCL_OBJ_GET_CHAR_SLOT(ass->car), HCL_OBJ_GET_SIZE(key)))
#else
n = hcl_equalobjs(hcl, key, ass->car); n = hcl_equalobjs(hcl, key, ass->car);
if (n <= -1) return HCL_NULL; if (n <= -1) return HCL_NULL;
if (n >= 1) if (n >= 1)
#endif
{ {
/* the value of HCL_NULL indicates no insertion or update. */ /* the value of HCL_NULL indicates no insertion or update. */
if (value) ass->cdr = value; /* update */ if (value)
{
if (is_method)
{
HCL_ASSERT (hcl, HCL_IS_CONS(hcl, ass->cdr));
HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, value));
if (is_method & 1) ((hcl_oop_cons_t)(ass->cdr))->car = value; /* class method */
if (is_method & 2) ((hcl_oop_cons_t)(ass->cdr))->cdr = value; /* instance method */
/* the class instantiation method goes to both cells.
* you can't define a class method or an instance method with the name of
* a class instantiation method */
}
else ass->cdr = value; /* normal update */
}
return ass; return ass;
} }
#endif
index = (index + 1) % HCL_OBJ_GET_SIZE(dic->bucket); index = (index + 1) % HCL_OBJ_GET_SIZE(dic->bucket);
} }
@ -202,15 +211,26 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t k
hcl_hashobj(hcl, key, &index); /* this must succeed as i know 'key' is hashable */ hcl_hashobj(hcl, key, &index); /* this must succeed as i know 'key' is hashable */
index %= HCL_OBJ_GET_SIZE(dic->bucket); index %= HCL_OBJ_GET_SIZE(dic->bucket);
#endif #endif
while (dic->bucket->slot[index] != hcl->_nil) while (dic->bucket->slot[index] != hcl->_nil)
index = (index + 1) % HCL_OBJ_GET_SIZE(dic->bucket); index = (index + 1) % HCL_OBJ_GET_SIZE(dic->bucket);
} }
if (is_method)
{
/* create a new association that holds a class method at the first cell and an instance method at the second cell */
hcl_oop_t newval;
HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, value));
hcl_pushvolat (hcl, &key);
newval = hcl_makecons(hcl, (is_method & 1? value: hcl->_nil), (is_method & 2? value: hcl->_nil));
hcl_popvolat (hcl);
if (HCL_UNLIKELY(!newval)) goto oops;
value = newval;
}
/* create a new assocation of a key and a value since /* create a new assocation of a key and a value since
* the key isn't found in the root dictionary */ * the key isn't found in the root dictionary */
ass = (hcl_oop_cons_t)hcl_makecons(hcl, (hcl_oop_t)key, value); ass = (hcl_oop_cons_t)hcl_makecons(hcl, (hcl_oop_t)key, value);
if (!ass) goto oops; if (HCL_UNLIKELY(!ass)) goto oops;
/* the current tally must be less than the maximum value. otherwise, /* the current tally must be less than the maximum value. otherwise,
* it overflows after increment below */ * it overflows after increment below */
@ -288,7 +308,7 @@ hcl_oop_cons_t hcl_putatsysdic (hcl_t* hcl, hcl_oop_t key, hcl_oop_t value)
#if defined(SYMBOL_ONLY_KEY) #if defined(SYMBOL_ONLY_KEY)
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
#endif #endif
return find_or_upsert(hcl, hcl->sysdic, key, value); return find_or_upsert(hcl, hcl->sysdic, key, value, 0);
} }
hcl_oop_cons_t hcl_getatsysdic (hcl_t* hcl, hcl_oop_t key) hcl_oop_cons_t hcl_getatsysdic (hcl_t* hcl, hcl_oop_t key)
@ -296,7 +316,7 @@ hcl_oop_cons_t hcl_getatsysdic (hcl_t* hcl, hcl_oop_t key)
#if defined(SYMBOL_ONLY_KEY) #if defined(SYMBOL_ONLY_KEY)
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
#endif #endif
return find_or_upsert(hcl, hcl->sysdic, key, HCL_NULL); return find_or_upsert(hcl, hcl->sysdic, key, HCL_NULL, 0);
} }
hcl_oop_cons_t hcl_lookupsysdicforsymbol_noseterr (hcl_t* hcl, const hcl_oocs_t* name) hcl_oop_cons_t hcl_lookupsysdicforsymbol_noseterr (hcl_t* hcl, const hcl_oocs_t* name)
@ -322,7 +342,15 @@ hcl_oop_cons_t hcl_putatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key, hcl_o
#if defined(SYMBOL_ONLY_KEY) #if defined(SYMBOL_ONLY_KEY)
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
#endif #endif
return find_or_upsert(hcl, dic, key, value); return find_or_upsert(hcl, dic, key, value, 0);
}
hcl_oop_cons_t hcl_putatdic_method (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key, hcl_oop_t value, int mtype)
{
#if defined(SYMBOL_ONLY_KEY)
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
#endif
return find_or_upsert(hcl, dic, key, value, mtype);
} }
hcl_oop_cons_t hcl_getatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key) hcl_oop_cons_t hcl_getatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key)
@ -330,7 +358,7 @@ hcl_oop_cons_t hcl_getatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key)
#if defined(SYMBOL_ONLY_KEY) #if defined(SYMBOL_ONLY_KEY)
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
#endif #endif
return find_or_upsert(hcl, dic, key, HCL_NULL); return find_or_upsert(hcl, dic, key, HCL_NULL, 0);
} }
int hcl_zapatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key) int hcl_zapatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key)

5
lib/err.c
View File

@ -137,8 +137,9 @@ static char* synerrstr[] =
"::: disallowed", "::: disallowed",
"loop body too big", "loop body too big",
"if body too big", "if body too big",
"lambda block too big", "block too big",
"lambda block too deep", "block too deep",
"name expected",
"argument name list expected", "argument name list expected",
"argument name expected", "argument name expected",
"duplicate argument name", "duplicate argument name",

47
lib/exec.c
View File

@ -2163,7 +2163,6 @@ static hcl_oop_lambda_t find_cmethod_noseterr (hcl_t* hcl, hcl_oop_class_t class
{ {
hcl_oop_t dic; hcl_oop_t dic;
dic = class_->mdic; dic = class_->mdic;
HCL_ASSERT (hcl, HCL_IS_NIL(hcl, dic) || HCL_IS_DIC(hcl, dic)); HCL_ASSERT (hcl, HCL_IS_NIL(hcl, dic) || HCL_IS_DIC(hcl, dic));
@ -3862,7 +3861,7 @@ static int execute (hcl_t* hcl)
else ivars_str = hcl->_nil; else ivars_str = hcl->_nil;
HCL_STACK_POP_TO(hcl, class_name); HCL_STACK_POP_TO(hcl, class_name);
HCL_ASSERT (hcl, HCL_IS_NIL(hcl, class_name) || HCL_IS_STRING(hcl, class_name)); HCL_ASSERT (hcl, HCL_IS_NIL(hcl, class_name) || HCL_IS_SYMBOL(hcl, class_name));
if (b1 > 0) if (b1 > 0)
{ {
@ -3876,6 +3875,17 @@ static int execute (hcl_t* hcl)
} }
else superclass = hcl->_nil; else superclass = hcl->_nil;
//////////////
hcl_logbfmt(hcl, HCL_LOG_STDERR, "class_name in class_enter 111>>>[%O]<<<\n", class_name);
if (HCL_IS_SYMBOL(hcl, class_name))
{
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, .... */
}
//////////////
t = hcl_makeclass(hcl, class_name, superclass, b2, b3, ivars_str, cvars_str); /* TOOD: pass variable information... */ 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; if (HCL_UNLIKELY(!t)) goto oops_with_errmsg_supplement;
@ -3914,46 +3924,41 @@ static int execute (hcl_t* hcl)
} }
case HCL_CODE_CLASS_CMSTORE: case HCL_CODE_CLASS_CMSTORE:
case HCL_CODE_CLASS_CIMSTORE:
case HCL_CODE_CLASS_IMSTORE: case HCL_CODE_CLASS_IMSTORE:
case HCL_CODE_CLASS_CIMSTORE:
{ {
hcl_oop_t class_; hcl_oop_t _class;
hcl_oop_t mdic, cons, blk, car, cdr, name; hcl_oop_t mdic, cons, blk, car, cdr, name;
int mtype;
static hcl_bch_t* pfx[] = { "c", "i", "ci" };
mtype = (bcode - HCL_CODE_CLASS_CMSTORE) + 1;
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_2 (hcl, "class_%hsmstore @%zu", (bcode == HCL_CODE_CLASS_CMSTORE? "c": (bcode == HCL_CODE_CLASS_CIMSTORE? "ci": "i")), b1); LOG_INST_2 (hcl, "class_%hsmstore @%zu", pfx[mtype], b1);
/* store the stack top in the member dictionary of the currect class with the key indicated by 'b1' */ /* store the stack top in the member dictionary of the currect class with the key indicated by 'b1' */
HCL_ASSERT (hcl, !HCL_CLSTACK_IS_EMPTY(hcl)); HCL_ASSERT (hcl, !HCL_CLSTACK_IS_EMPTY(hcl));
HCL_CLSTACK_FETCH_TOP_TO (hcl, class_); HCL_CLSTACK_FETCH_TOP_TO (hcl, _class);
HCL_ASSERT (hcl, HCL_IS_CLASS(hcl, class_)); HCL_ASSERT (hcl, HCL_IS_CLASS(hcl, _class));
mdic = ((hcl_oop_class_t)class_)->mdic; /* instance-side dictionary */ mdic = ((hcl_oop_class_t)_class)->mdic; /* instance-side dictionary */
HCL_ASSERT (hcl, HCL_IS_NIL(hcl, mdic) || HCL_IS_DIC(hcl, mdic)); HCL_ASSERT (hcl, HCL_IS_NIL(hcl, mdic) || HCL_IS_DIC(hcl, mdic));
if (HCL_IS_NIL(hcl, mdic)) if (HCL_IS_NIL(hcl, mdic))
{ {
hcl_pushvolat (hcl, (hcl_oop_t*)&class_); hcl_pushvolat (hcl, (hcl_oop_t*)&_class);
mdic = hcl_makedic(hcl, 16); /* TODO: configurable initial size? */ mdic = hcl_makedic(hcl, 16); /* TODO: configurable initial size? */
hcl_popvolat (hcl); hcl_popvolat (hcl);
if (HCL_UNLIKELY(!mdic)) goto oops_with_errmsg_supplement; if (HCL_UNLIKELY(!mdic)) goto oops_with_errmsg_supplement;
((hcl_oop_class_t)class_)->mdic = mdic; ((hcl_oop_class_t)_class)->mdic = mdic;
} }
blk = HCL_STACK_GETTOP(hcl); blk = HCL_STACK_GETTOP(hcl);
hcl_pushvolat (hcl, (hcl_oop_t*)&mdic);
/* let car point to the instance method,
* let cdr point to the class method */
car = (bcode == HCL_CODE_CLASS_IMSTORE? hcl->_nil: blk);
cdr = (bcode == HCL_CODE_CLASS_CMSTORE? hcl->_nil: blk);
cons = hcl_makecons(hcl, car, cdr);
hcl_popvolat (hcl);
if (HCL_UNLIKELY(!cons)) goto oops_with_errmsg_supplement;
/* put the code at method dictionary */
name = hcl->active_function->literal_frame[b1]; /* method name */ name = hcl->active_function->literal_frame[b1]; /* method name */
if (!hcl_putatdic(hcl, (hcl_oop_dic_t)mdic, name, cons)) goto oops_with_errmsg_supplement; /* put the code at method dictionary
pass 1 for class method, 2 for instance method, 3 for class instantiation method */
if (!hcl_putatdic_method(hcl, (hcl_oop_dic_t)mdic, name, blk, mtype)) goto oops_with_errmsg_supplement;
break; break;
} }
/* -------------------------------------------------------- */ /* -------------------------------------------------------- */

16
lib/hcl-prv.h
View File

@ -1339,8 +1339,8 @@ enum hcl_bcode_t
HCL_CODE_PUSH_OBJVAR_X = 0xE4, /* 228 ## */ HCL_CODE_PUSH_OBJVAR_X = 0xE4, /* 228 ## */
HCL_CODE_CLASS_CMSTORE = 0xE5, /* 229 */ HCL_CODE_CLASS_CMSTORE = 0xE5, /* 229 */
HCL_CODE_CLASS_CIMSTORE = 0xE6, /* 230 */ HCL_CODE_CLASS_IMSTORE = 0xE6, /* 230 */
HCL_CODE_CLASS_IMSTORE = 0xE7, /* 231 */ HCL_CODE_CLASS_CIMSTORE = 0xE7, /* 231 */
HCL_CODE_STORE_INTO_OBJVAR_X = 0xE8, /* 232 ## */ HCL_CODE_STORE_INTO_OBJVAR_X = 0xE8, /* 232 ## */
HCL_CODE_MAKE_ARRAY = 0xE9, /* 233 ## */ HCL_CODE_MAKE_ARRAY = 0xE9, /* 233 ## */
@ -1536,6 +1536,18 @@ hcl_oop_t hcl_findsymbol (
); );
/* ========================================================================= */
/* dic.c */
/* ========================================================================= */
hcl_oop_cons_t hcl_putatdic_method (
hcl_t* hcl,
hcl_oop_dic_t dic,
hcl_oop_t key,
hcl_oop_t value,
int mtype /* 1 for class method, 2 for instance method */
);
/* ========================================================================= */ /* ========================================================================= */
/* proc.c */ /* proc.c */
/* ========================================================================= */ /* ========================================================================= */

5
lib/hcl.h
View File

@ -141,8 +141,9 @@ enum hcl_synerrnum_t
HCL_SYNERR_TRPCOLONSBANNED, /* ::: disallowed */ HCL_SYNERR_TRPCOLONSBANNED, /* ::: disallowed */
HCL_SYNERR_LOOPFLOOD, /* loop body too big */ HCL_SYNERR_LOOPFLOOD, /* loop body too big */
HCL_SYNERR_IFFLOOD, /* if body too big */ HCL_SYNERR_IFFLOOD, /* if body too big */
HCL_SYNERR_BLKFLOOD, /* lambda block too big */ HCL_SYNERR_BLKFLOOD, /* block too big */
HCL_SYNERR_BLKDEPTH, /* lambda block too deep */ HCL_SYNERR_BLKDEPTH, /* block too deep */
HCL_SYNERR_NAME, /* name expected */
HCL_SYNERR_ARGNAMELIST, /* argument name list expected */ HCL_SYNERR_ARGNAMELIST, /* argument name list expected */
HCL_SYNERR_ARGNAME, /* argument name expected */ HCL_SYNERR_ARGNAME, /* argument name expected */
HCL_SYNERR_ARGNAMEDUP, /* duplicate argument name */ HCL_SYNERR_ARGNAMEDUP, /* duplicate argument name */

21
lib/print.c
View File

@ -692,14 +692,31 @@ next:
goto print_word; goto print_word;
case HCL_BRAND_CLASS: case HCL_BRAND_CLASS:
/* TODO: print the class name */ {
hcl_oop_class_t _class = (hcl_oop_class_t)obj;
if (HCL_IS_NIL(hcl, _class->name))
{
word_index = WORD_CLASS; word_index = WORD_CLASS;
goto print_word; goto print_word;
}
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, _class->name));
if (hcl_bfmt_out(hcl, fmtout, "%.*js", HCL_OBJ_GET_SIZE(_class->name), HCL_OBJ_GET_CHAR_SLOT(_class->name)) <= -1) return -1;
break;
}
case HCL_BRAND_INSTANCE: case HCL_BRAND_INSTANCE:
/* TODO: print the class name also */ {
hcl_oop_class_t _class = (hcl_oop_class_t)HCL_CLASSOF(hcl, obj);
HCL_ASSERT (hcl, HCL_IS_CLASS(hcl, _class));
if (HCL_IS_NIL(hcl, _class->name))
{
word_index = WORD_INSTANCE; word_index = WORD_INSTANCE;
goto print_word; goto print_word;
}
HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, _class->name));
if (hcl_bfmt_out(hcl, fmtout, "#INSTANCE OF %.*js", HCL_OBJ_GET_SIZE(_class->name), HCL_OBJ_GET_CHAR_SLOT(_class->name)) <= -1) return -1;
break;
}
default: default:
HCL_DEBUG3 (hcl, "Internal error - unknown object type %d at %s:%d\n", (int)brand, __FILE__, __LINE__); HCL_DEBUG3 (hcl, "Internal error - unknown object type %d at %s:%d\n", (int)brand, __FILE__, __LINE__);

5
mod/core.c
View File

@ -35,8 +35,13 @@ static hcl_pfrc_t pf_core_get_class_name (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t
if (!HCL_IS_CLASS(hcl, obj)) if (!HCL_IS_CLASS(hcl, obj))
{ {
#if 0
hcl_seterrbfmt (hcl, HCL_EINVAL, "parameter not a class - %O", obj); hcl_seterrbfmt (hcl, HCL_EINVAL, "parameter not a class - %O", obj);
return HCL_PF_FAILURE; return HCL_PF_FAILURE;
#else
obj = (hcl_oop_oop_t)HCL_CLASSOF(hcl, obj);
HCL_ASSERT (hcl, HCL_IS_CLASS(hcl, obj));
#endif
} }
HCL_STACK_SETRET (hcl, nargs, ((hcl_oop_class_t)obj)->name); HCL_STACK_SETRET (hcl, nargs, ((hcl_oop_class_t)obj)->name);