From f21669924027999fc608704d4e99a41fed3e0c18 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Fri, 19 Jul 2024 20:50:28 +0900 Subject: [PATCH] enhanced the print function to print the class name for a class enahnced the compiler to handle class defintion better. updated method management routines into method dictionary --- lib/comp.c | 83 +++++++++++++++++++++++++-------------------------- lib/dic.c | 78 +++++++++++++++++++++++++++++++---------------- lib/err.c | 5 ++-- lib/exec.c | 47 ++++++++++++++++------------- lib/hcl-prv.h | 16 ++++++++-- lib/hcl.h | 5 ++-- lib/print.c | 29 ++++++++++++++---- mod/core.c | 7 ++++- 8 files changed, 169 insertions(+), 101 deletions(-) diff --git a/lib/comp.c b/lib/comp.c index c5bee24..4ee7ea4 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -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) { - hcl_cnode_t* cmd, * obj; - hcl_cnode_t* class_name; hcl_cframe_t* cf; + hcl_cnode_t* cmd, * obj, * tmp; + hcl_cnode_t* class_name, * superclass; + int nsuperclasses; cmd = HCL_CNODE_CONS_CAR(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: 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; } 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; } -/* 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); } else @@ -2560,64 +2559,64 @@ static int compile_class (hcl_t* hcl, hcl_cnode_t* src, int defclass) 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); - if (/*!HCL_CNODE_IS_COLON(marker)*/!HCL_CNODE_IS_DBLCOLONS(marker)) goto no_superclass; + tmp = HCL_CNODE_CONS_CAR(obj); + 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); 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; } /* superclass part */ - tmp = HCL_CNODE_CONS_CAR(obj); - if (!HCL_CNODE_IS_SYMBOL_PLAIN(tmp)) + superclass = HCL_CNODE_CONS_CAR(obj); + 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; } - SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, tmp); /* 1 - superclass expression */ - PUSH_SUBCFRAME (hcl, COP_COMPILE_CLASS_P2, class_name); /* 4 - class name */ - cf = GET_SUBCFRAME(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; + //SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, tmp); /* 1 - superclass expression */ + nsuperclasses = 1; 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 { - no_superclass: - 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 */ - cf = GET_SUBCFRAME(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 */ - cf = GET_TOP_CFRAME(hcl); - cf->u._class.nsuperclasses = 0; /* 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; + 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 */ + PUSH_SUBCFRAME (hcl, COP_COMPILE_CLASS_P2, class_name); /* 3 - use class name for assignment */ + cf = GET_SUBCFRAME(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 */ + cf = GET_SUBCFRAME(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 */ return 0; } @@ -4617,7 +4616,7 @@ static int compile_symbol_literal (hcl_t* hcl) /* treat a symbol as a string */ /* 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 (emit_push_literal(hcl, lit, HCL_CNODE_GET_LOC(oprnd)) <= -1) return -1; diff --git a/lib/dic.c b/lib/dic.c index afcf6ae..e2cb9a7 100644 --- a/lib/dic.c +++ b/lib/dic.c @@ -95,7 +95,7 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc) 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_oow_t index; @@ -120,33 +120,42 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t k /* find */ while (dic->bucket->slot[index] != hcl->_nil) { - #if defined(SYMBOL_ONLY_KEY) +#if defined(SYMBOL_ONLY_KEY) + /* nothing */ +#else + int n; +#endif + ass = (hcl_oop_cons_t)dic->bucket->slot[index]; HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass)); - HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,ass->car)); +#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))) - { - /* the value of HCL_NULL indicates no insertion or update. */ - if (value) ass->cdr = value; /* update */ - return ass; - } - #else - int n; - - ass = (hcl_oop_cons_t)dic->bucket->slot[index]; - HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass)); - +#else n = hcl_equalobjs(hcl, key, ass->car); if (n <= -1) return HCL_NULL; if (n >= 1) +#endif { /* 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; } - #endif index = (index + 1) % HCL_OBJ_GET_SIZE(dic->bucket); } @@ -195,22 +204,33 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t k dic->bucket = bucket; - #if defined(SYMBOL_ONLY_KEY) +#if defined(SYMBOL_ONLY_KEY) /* recalculate the index for the expanded bucket */ index = hcl_hash_oochars(HCL_OBJ_GET_CHAR_SLOT(key), HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket); - #else +#else hcl_hashobj(hcl, key, &index); /* this must succeed as i know 'key' is hashable */ index %= HCL_OBJ_GET_SIZE(dic->bucket); - #endif - +#endif while (dic->bucket->slot[index] != hcl->_nil) 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 * the key isn't found in the root dictionary */ 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, * 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) HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); #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) @@ -296,7 +316,7 @@ hcl_oop_cons_t hcl_getatsysdic (hcl_t* hcl, hcl_oop_t key) #if defined(SYMBOL_ONLY_KEY) HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); #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) @@ -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) HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); #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) @@ -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) HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key)); #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) diff --git a/lib/err.c b/lib/err.c index f1b22a1..dfb33f8 100644 --- a/lib/err.c +++ b/lib/err.c @@ -137,8 +137,9 @@ static char* synerrstr[] = "::: disallowed", "loop body too big", "if body too big", - "lambda block too big", - "lambda block too deep", + "block too big", + "block too deep", + "name expected", "argument name list expected", "argument name expected", "duplicate argument name", diff --git a/lib/exec.c b/lib/exec.c index 0dcd2a0..14e9c89 100644 --- a/lib/exec.c +++ b/lib/exec.c @@ -2163,7 +2163,6 @@ static hcl_oop_lambda_t find_cmethod_noseterr (hcl_t* hcl, hcl_oop_class_t class { hcl_oop_t dic; - dic = class_->mdic; 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; 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) { @@ -3876,6 +3875,17 @@ static int execute (hcl_t* hcl) } 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... */ 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_CIMSTORE: 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; + int mtype; + static hcl_bch_t* pfx[] = { "c", "i", "ci" }; + mtype = (bcode - HCL_CODE_CLASS_CMSTORE) + 1; 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' */ HCL_ASSERT (hcl, !HCL_CLSTACK_IS_EMPTY(hcl)); - HCL_CLSTACK_FETCH_TOP_TO (hcl, class_); - HCL_ASSERT (hcl, HCL_IS_CLASS(hcl, class_)); + HCL_CLSTACK_FETCH_TOP_TO (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)); 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? */ hcl_popvolat (hcl); 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); - 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 */ - 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; } /* -------------------------------------------------------- */ diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index 1c0a77e..935ef93 100644 --- a/lib/hcl-prv.h +++ b/lib/hcl-prv.h @@ -1339,8 +1339,8 @@ enum hcl_bcode_t HCL_CODE_PUSH_OBJVAR_X = 0xE4, /* 228 ## */ HCL_CODE_CLASS_CMSTORE = 0xE5, /* 229 */ - HCL_CODE_CLASS_CIMSTORE = 0xE6, /* 230 */ - HCL_CODE_CLASS_IMSTORE = 0xE7, /* 231 */ + HCL_CODE_CLASS_IMSTORE = 0xE6, /* 230 */ + HCL_CODE_CLASS_CIMSTORE = 0xE7, /* 231 */ HCL_CODE_STORE_INTO_OBJVAR_X = 0xE8, /* 232 ## */ 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 */ /* ========================================================================= */ diff --git a/lib/hcl.h b/lib/hcl.h index 2fa72db..ab4b75f 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -141,8 +141,9 @@ enum hcl_synerrnum_t HCL_SYNERR_TRPCOLONSBANNED, /* ::: disallowed */ HCL_SYNERR_LOOPFLOOD, /* loop body too big */ HCL_SYNERR_IFFLOOD, /* if body too big */ - HCL_SYNERR_BLKFLOOD, /* lambda block too big */ - HCL_SYNERR_BLKDEPTH, /* lambda block too deep */ + HCL_SYNERR_BLKFLOOD, /* block too big */ + HCL_SYNERR_BLKDEPTH, /* block too deep */ + HCL_SYNERR_NAME, /* name expected */ HCL_SYNERR_ARGNAMELIST, /* argument name list expected */ HCL_SYNERR_ARGNAME, /* argument name expected */ HCL_SYNERR_ARGNAMEDUP, /* duplicate argument name */ diff --git a/lib/print.c b/lib/print.c index f3e6732..a47ba1a 100644 --- a/lib/print.c +++ b/lib/print.c @@ -692,14 +692,31 @@ next: goto print_word; case HCL_BRAND_CLASS: - /* TODO: print the class name */ - word_index = WORD_CLASS; - goto print_word; + { + hcl_oop_class_t _class = (hcl_oop_class_t)obj; + if (HCL_IS_NIL(hcl, _class->name)) + { + word_index = WORD_CLASS; + 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: - /* TODO: print the class name also */ - word_index = WORD_INSTANCE; - goto print_word; + { + 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; + 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: HCL_DEBUG3 (hcl, "Internal error - unknown object type %d at %s:%d\n", (int)brand, __FILE__, __LINE__); diff --git a/mod/core.c b/mod/core.c index 4810e9b..f91c2da 100644 --- a/mod/core.c +++ b/mod/core.c @@ -33,10 +33,15 @@ static hcl_pfrc_t pf_core_get_class_name (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t obj = (hcl_oop_oop_t)HCL_STACK_GETARG(hcl, nargs, 0); - 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); 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);