diff --git a/hcl/lib/comp.c b/hcl/lib/comp.c index eeea555..ae0037b 100644 --- a/hcl/lib/comp.c +++ b/hcl/lib/comp.c @@ -1587,6 +1587,90 @@ static HCL_INLINE int compile_else (hcl_t* hcl) return patch_nearest_post_if_body(hcl, cmd); } +/* ========================================================================= */ +static int compile_defclass (hcl_t* hcl, hcl_cnode_t* src) +{ + /* + (defclass A + | x y | ; instance variables + | ::: x y z | ; class variables <--- how to initialize the class variables??? + + + (defcmethod new (a b c) +(printf "%O\n" self) ; self is A + (set obj super.new) + (obj.init a b c) + ;(obj.x 10) + ;(obj.y 20) + (return obj) + ) + ) + + (defclass B ::: A ; A is a parent class + | p q | + + .... + ) + + */ + hcl_cnode_t* cmd, * obj, * args; + hcl_cnode_t* defun_name; + + cmd = HCL_CNODE_CONS_CAR(src); + obj = HCL_CNODE_CONS_CDR(src); + + HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(cmd, HCL_SYNCODE_DEFUN)); + + 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)); + return -1; + } + else if (!HCL_CNODE_IS_CONS(obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); + return -1; + } + + class_name = HCL_CNODE_CONS_CAR(obj); + if (HCL_CNODE_IS_SYMBOL(class_name)) + { + /* defclass followed by a class name */ + if (HCL_CNODE_SYMBOL_SYNCODE(class_name)) /*|| HCL_OBJ_GET_FLAGS_KERNEL(class_name) >= 1) */ + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_CNODE_GET_LOC(class_name), HCL_CNODE_GET_TOK(class_name), "special symbol not to be used as a defun name"); + return -1; + } + + obj = HCL_CNODE_CONS_CDR(obj); + } + else + { + /* no class name specified */ + class_name = HCL_NULL; + } + + if (HCL_CNODE_IS_ELLIPSIS(arg)) + { + /* superclass */ + } + + if (!obj) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_CNODE_GET_LOC(src), HCL_NULL, "no argument list in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); + return -1; + } + else if (!HCL_CNODE_IS_CONS(obj)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "redundant cdr in argument list in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); + return -1; + } + HCL_CNODE_CONS_CAR(obj); + + + return 0; +} + /* ========================================================================= */ static int collect_local_vardcl (hcl_t* hcl, hcl_cnode_t* obj, hcl_cnode_t** nextobj, hcl_oow_t tv_dup_check_start, hcl_oow_t* nvardcls) @@ -2573,6 +2657,10 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj, int nret if (compile_continue(hcl, obj) <= -1) return -1; break; + case HCL_SYNCODE_DEFCLASS: + if (compile_defclass(hcl, obj) <= -1) return -1; + break; + case HCL_SYNCODE_DEFUN: if (compile_lambda(hcl, obj, 1) <= -1) return -1; break; diff --git a/hcl/lib/exec.c b/hcl/lib/exec.c index 07ab440..19fe933 100644 --- a/hcl/lib/exec.c +++ b/hcl/lib/exec.c @@ -3729,15 +3729,22 @@ static int execute (hcl_t* hcl) case HCL_CODE_MAKE_CLASS: { + /* push nivars + push ncvars + push superclass + //push ivarnames + //push cvarnames + make_classs + */ hcl_oop_t t, sc, nivars, ncvars; LOG_INST_0 (hcl, "make_class"); sc = HCL_STACK_GETTOP(hcl); HCL_STACK_POP(hcl); - nivars = HCL_STACK_GETTOP(hcl); HCL_STACK_POP(hcl); ncvars = HCL_STACK_GETTOP(hcl); HCL_STACK_POP(hcl); - HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(nivars)); + nivars = HCL_STACK_GETTOP(hcl); HCL_STACK_POP(hcl); HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(ncvars)); + HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(nivars)); t = hcl_makeclass(hcl, sc, HCL_OOP_TO_SMOOI(nivars), HCL_OOP_TO_SMOOI(ncvars)); if (HCL_UNLIKELY(!t)) @@ -3749,6 +3756,11 @@ static int execute (hcl_t* hcl) HCL_STACK_PUSH (hcl, t); /* push the class created */ break; } + + /*case HCL_CODE_MAKE_METHOD: + { + }*/ + /* -------------------------------------------------------- */ case HCL_CODE_DUP_STACKTOP: diff --git a/hcl/lib/gc.c b/hcl/lib/gc.c index 546f540..c190100 100644 --- a/hcl/lib/gc.c +++ b/hcl/lib/gc.c @@ -43,6 +43,7 @@ static struct { 5, { 'b','r','e','a','k' }, HCL_SYNCODE_BREAK, HCL_OFFSETOF(hcl_t,_break) }, { 5, { 'c','a','t','c','h' }, HCL_SYNCODE_CATCH, HCL_OFFSETOF(hcl_t,_catch) }, { 8, { 'c','o','n','t','i','n','u','e' }, HCL_SYNCODE_CONTINUE, HCL_OFFSETOF(hcl_t,_continue) }, + { 8, { 'd','e','f','c','l','a','s','s' }, HCL_SYNCODE_DEFCLASS, HCL_OFFSETOF(hcl_t,_defclass) }, { 5, { 'd','e','f','u','n' }, HCL_SYNCODE_DEFUN, HCL_OFFSETOF(hcl_t,_defun) }, { 2, { 'd','o' }, HCL_SYNCODE_DO, HCL_OFFSETOF(hcl_t,_do) }, { 4, { 'e','l','i','f' }, HCL_SYNCODE_ELIF, HCL_OFFSETOF(hcl_t,_elif) }, diff --git a/hcl/lib/hcl.h b/hcl/lib/hcl.h index 8ada514..aaa83c6 100644 --- a/hcl/lib/hcl.h +++ b/hcl/lib/hcl.h @@ -1505,6 +1505,7 @@ struct hcl_t hcl_oop_t _break; /* symbol */ hcl_oop_t _catch; /* symbol */ hcl_oop_t _continue; /* symbol */ + hcl_oop_t _defclass; /* symbol */ hcl_oop_t _defun; /* symbol */ hcl_oop_t _do; /* symbol */ hcl_oop_t _elif; /* symbol */ @@ -1784,6 +1785,7 @@ enum hcl_syncode_t HCL_SYNCODE_BREAK, HCL_SYNCODE_CATCH, HCL_SYNCODE_CONTINUE, + HCL_SYNCODE_DEFCLASS, HCL_SYNCODE_DEFUN, HCL_SYNCODE_DO, HCL_SYNCODE_ELIF,