From f6d97f83015e95d79f763b64098c9b343aa35ce2 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Sat, 28 Sep 2024 11:57:56 +0900 Subject: [PATCH] let 'fun' replace 'defun' totally --- lib/comp.c | 139 ++++++++++++++++++++++++----------------------- lib/gc.c | 1 - lib/hcl-prv.h | 19 ++++++- lib/hcl.h | 21 ++++++- lib/prim.c | 46 ++++++++++++++++ lib/read.c | 13 ++--- t/class-5001.err | 4 +- t/feed-01.hcl | 2 +- t/feed-5001.err | 4 +- t/fun-01.hcl | 18 +++--- t/insta-01.hcl | 18 +++--- t/insta-02.hcl | 4 +- t/proc-01.hcl | 4 +- t/retvar-01.hcl | 6 +- t/va-01.hcl | 4 +- t/var-01.hcl | 10 ++-- t/var-02.hcl | 2 +- t/var-5001.err | 6 +- t/var-5004.err | 2 +- 19 files changed, 203 insertions(+), 120 deletions(-) diff --git a/lib/comp.c b/lib/comp.c index 2687371..23640c7 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -69,16 +69,16 @@ enum /* -------------------------------------------- -(defun plus(x y) +(fun plus(x y) (printf "plus %d %d\n" x y) - (defun minus(x y) + (fun minus(x y) (printf "minus %d %d\n" x y) (- x y) ) (+ x y) ) -(defun dummy(q) +(fun dummy(q) (printf "%s\n" q) ) @@ -2492,7 +2492,7 @@ static HCL_INLINE int compile_else (hcl_t* hcl) (set x 20) (printf "normal statement ....\n"); - (defun new (a b c) + (fun new (a b c) (printf "%O\n" self) ; self is A (set obj super.new) (obj.init a b c) @@ -2814,46 +2814,45 @@ static HCL_INLINE int compile_class_p2 (hcl_t* hcl) /* ========================================================================= */ -static int compile_fun (hcl_t* hcl, hcl_cnode_t* src, int defun) +static int compile_fun (hcl_t* hcl, hcl_cnode_t* src) { hcl_cnode_t* cmd, * obj, * args; hcl_oow_t va, nargs, nrvars, nlvars; hcl_ooi_t jump_inst_pos, lfbase_pos, lfsize_pos; hcl_oow_t saved_tv_wcount, tv_dup_start; - hcl_cnode_t* defun_name; + hcl_cnode_t* fun_name; hcl_cnode_t* class_name; hcl_cframe_t* cf; unsigned int fun_type = FUN_PLAIN; + int named = 0; HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src)); saved_tv_wcount = hcl->c->tv.wcount; cmd = HCL_CNODE_CONS_CAR(src); obj = HCL_CNODE_CONS_CDR(src); - class_name = HCL_NULL; - if (!defun && (obj && HCL_CNODE_IS_CONS(obj))) + HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(cmd, HCL_SYNCODE_FUN) || + HCL_CNODE_IS_TYPED(cmd, HCL_CNODE_FUN)); + + if (obj && HCL_CNODE_IS_CONS(obj)) { - /* some inaccurate prior check if 'fun' is followed by an argument list - * without a function name. stop-gap measure to support 'fun' in place of 'defun' */ - HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(cmd, HCL_SYNCODE_FUN) || HCL_CNODE_IS_TYPED(cmd, HCL_CNODE_FUN)); + /* inaccurate pre-check if 'fun' is followed by an argument list + * without a function name. */ args = HCL_CNODE_CONS_CAR(obj); if (!HCL_CNODE_IS_ELIST_CONCODED(args, HCL_CONCODE_XLIST) && !HCL_CNODE_IS_CONS_CONCODED(args, HCL_CONCODE_XLIST)) { /* not followed by an argument list */ - defun = 1; - goto fun_as_defun; + named = 1; + goto named_function; } } - if (defun) + if (named) { - /* defun must be followed by an explicit function name */ - HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(cmd, HCL_SYNCODE_DEFUN)); - - fun_as_defun: + named_function: 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)); @@ -2865,13 +2864,13 @@ static int compile_fun (hcl_t* hcl, hcl_cnode_t* src, int defun) return -1; } - defun_name = HCL_CNODE_CONS_CAR(obj); + fun_name = HCL_CNODE_CONS_CAR(obj); if (is_in_class_init_scope(hcl)) { - if ((HCL_CNODE_IS_DBLCOLONS(defun_name) || HCL_CNODE_IS_COLONSTAR(defun_name))) + if ((HCL_CNODE_IS_DBLCOLONS(fun_name) || HCL_CNODE_IS_COLONSTAR(fun_name))) { - /* class method - (defun ::xxxx () ...) inside class definition */ - /* class instantiation method - (defun :*xxxx() ...) inside class definition */ + /* class method - (fun ::xxxx () ...) inside class definition */ + /* class instantiation method - (fun :*xxxx() ...) inside class definition */ obj = HCL_CNODE_CONS_CDR(obj); if (!obj) { @@ -2879,14 +2878,14 @@ static int compile_fun (hcl_t* hcl, hcl_cnode_t* src, int defun) return -1; } - fun_type = HCL_CNODE_IS_DBLCOLONS(defun_name)? FUN_CM: FUN_CIM; - defun_name = HCL_CNODE_CONS_CAR(obj); /* advance to the actual name */ + fun_type = HCL_CNODE_IS_DBLCOLONS(fun_name)? FUN_CM: FUN_CIM; + fun_name = HCL_CNODE_CONS_CAR(obj); /* advance to the actual name */ } else { - if (HCL_CNODE_IS_SYMBOL_PLAIN(defun_name)) + if (HCL_CNODE_IS_SYMBOL_PLAIN(fun_name)) { - /* probably this form - defun XXX:yyy () ... + /* probably this form - fun XXX:yyy () ... * the class name must not be specified in the class initialization scope */ hcl_cnode_t* tmp; tmp = HCL_CNODE_CONS_CDR(obj); @@ -2897,7 +2896,7 @@ static int compile_fun (hcl_t* hcl, hcl_cnode_t* src, int defun) { hcl_setsynerrbfmt ( hcl, HCL_SYNERR_VARNAME, - HCL_CNODE_GET_LOC(defun_name), HCL_CNODE_GET_TOK(defun_name), + HCL_CNODE_GET_LOC(fun_name), HCL_CNODE_GET_TOK(fun_name), "function name not valid followed by %.*js", HCL_CNODE_GET_TOKLEN(tmp), HCL_CNODE_GET_TOKPTR(tmp)); return -1; @@ -2908,7 +2907,7 @@ static int compile_fun (hcl_t* hcl, hcl_cnode_t* src, int defun) fun_type = FUN_IM; } } - else if (HCL_CNODE_IS_SYMBOL_PLAIN(defun_name)) + else if (HCL_CNODE_IS_SYMBOL_PLAIN(fun_name)) { hcl_cnode_t* tmp, marker; tmp = HCL_CNODE_CONS_CDR(obj); @@ -2928,8 +2927,8 @@ static int compile_fun (hcl_t* hcl, hcl_cnode_t* src, int defun) if (HCL_CNODE_IS_SYMBOL_PLAIN(cand)) { /* out-of-class method definition - * for defun String:length() { ... }, - * class_name is String, defun_name is length. */ + * for fun String:length() { ... }, + * class_name is String, fun_name is length. */ fun_type = HCL_CNODE_IS_DBLCOLONS(marker)? FUN_CM: HCL_CNODE_IS_COLONSTAR(marker)? FUN_CIM: FUN_IM; @@ -2944,8 +2943,8 @@ static int compile_fun (hcl_t* hcl, hcl_cnode_t* src, int defun) * */ fun_type |= 0x100; - class_name = defun_name; - defun_name = HCL_CNODE_CONS_CAR(tmp); + class_name = fun_name; + fun_name = HCL_CNODE_CONS_CAR(tmp); obj = tmp; } } @@ -2953,15 +2952,22 @@ static int compile_fun (hcl_t* hcl, hcl_cnode_t* src, int defun) } } - if (!HCL_CNODE_IS_SYMBOL(defun_name)) + if (!HCL_CNODE_IS_SYMBOL(fun_name)) { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_CNODE_GET_LOC(defun_name), HCL_CNODE_GET_TOK(defun_name), "function name not symbol in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, + HCL_CNODE_GET_LOC(fun_name), HCL_NULL, + "invalid function name '%.*js' for '%.*js'", + HCL_CNODE_GET_TOKLEN(fun_name), HCL_CNODE_GET_TOKPTR(fun_name), + HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } - if (HCL_CNODE_SYMBOL_SYNCODE(defun_name)) /*|| HCL_OBJ_GET_FLAGS_KERNEL(defun_name) >= 1) */ + if (HCL_CNODE_SYMBOL_SYNCODE(fun_name)) /*|| HCL_OBJ_GET_FLAGS_KERNEL(fun_name) >= 1) */ { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_CNODE_GET_LOC(defun_name), HCL_CNODE_GET_TOK(defun_name), "special symbol not to be used as function name"); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, + HCL_CNODE_GET_LOC(fun_name), HCL_NULL, + "special symbol '%.*js' not to be used as function name", + HCL_CNODE_GET_TOKLEN(fun_name), HCL_CNODE_GET_TOKPTR(fun_name)); return -1; } @@ -2969,14 +2975,17 @@ static int compile_fun (hcl_t* hcl, hcl_cnode_t* src, int defun) } else { - HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(cmd, HCL_SYNCODE_FUN) || HCL_CNODE_IS_TYPED(cmd, HCL_CNODE_FUN)); - defun_name = HCL_NULL; + HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(cmd, HCL_SYNCODE_FUN) || + HCL_CNODE_IS_TYPED(cmd, HCL_CNODE_FUN)); + fun_name = HCL_NULL; } if (!obj) { no_arg_list: - hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_CNODE_GET_LOC(src), HCL_NULL, "argument list missing in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGNAMELIST, HCL_CNODE_GET_LOC(src), HCL_NULL, + "argument list missing in %.*js", + HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); return -1; } else if (!HCL_CNODE_IS_CONS(obj)) @@ -3115,8 +3124,8 @@ static int compile_fun (hcl_t* hcl, hcl_cnode_t* src, int defun) /* - * defun aa(a b) { ... }; - * (defun aa(a b) { ... }) + * fun aa(a b) { ... }; + * (fun aa(a b) { ... }) * * the block expression must be the first and the only expression at the body position. * the variable declaration can't be placed before the block expression. @@ -3154,7 +3163,7 @@ static int compile_fun (hcl_t* hcl, hcl_cnode_t* src, int defun) if (emit_single_param_instruction(hcl, HCL_CODE_JUMP_FORWARD_0, MAX_CODE_JUMP, HCL_CNODE_GET_LOC(cmd)) <= -1) return -1; SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_LIST, obj); /* 1 */ - PUSH_SUBCFRAME (hcl, COP_POST_FUN, defun_name); /* 3*/ + PUSH_SUBCFRAME (hcl, COP_POST_FUN, fun_name); /* 3*/ cf = GET_SUBCFRAME(hcl); cf->u.fun.fun_type = fun_type; cf->u.fun.class_name = class_name; @@ -3454,7 +3463,7 @@ static int compile_set_r (hcl_t* hcl, hcl_cnode_t* src) } /* - * (defun f(x y ::: aa bb cc) ....) + * (fun f(x y ::: aa bb cc) ....) * (set_r a b c (f 1 2)) * * the call to f @@ -3968,7 +3977,7 @@ static int compile_cons_alist_expression (hcl_t* hcl, hcl_cnode_t* cmd) } /* - * (defun f(x y ::: aa bb cc) ....) + * (fun f(x y ::: aa bb cc) ....) * ([a b c] := (f 1 2)) * * the call to f @@ -4050,7 +4059,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj, int nret goto done; case HCL_CNODE_FUN: - if (compile_fun(hcl, obj, 0) <= -1) return -1; + if (compile_fun(hcl, obj) <= -1) return -1; goto done; case HCL_CNODE_DO: @@ -4144,10 +4153,6 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj, int nret if (compile_class(hcl, obj, 1) <= -1) return -1; break; - case HCL_SYNCODE_DEFUN: - if (compile_fun(hcl, obj, 1) <= -1) return -1; - break; - case HCL_SYNCODE_DO: if (compile_do(hcl, obj) <= -1) return -1; break; @@ -4166,7 +4171,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj, int nret case HCL_SYNCODE_FUN: /* (fun (x y) (+ x y)) */ - if (compile_fun(hcl, obj, 0) <= -1) return -1; + if (compile_fun(hcl, obj) <= -1) return -1; break; case HCL_SYNCODE_OR: @@ -5969,19 +5974,19 @@ static HCL_INLINE int post_fun (hcl_t* hcl) if (cf->operand) { - /* (defun x() ; this x refers to a variable in the outer scope. + /* (fun x() ; this x refers to a variable in the outer scope. * | t1 t2 x | * (set x 10) ; this x refers to the local variable. * ) * * the block has been exited(blk.depth--) before finding 'x' in the outer scope. */ - hcl_cnode_t* defun_name = cf->operand; + hcl_cnode_t* fun_name = cf->operand; hcl_cnode_t* class_name = cf->u.fun.class_name; hcl_var_info_t vi; int x; - HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_PLAIN(defun_name)); + HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_PLAIN(fun_name)); if (is_in_class_init_scope(hcl)) { @@ -5995,7 +6000,7 @@ static HCL_INLINE int post_fun (hcl_t* hcl) return -1; } - x = find_variable_backward_with_token(hcl, defun_name, &vi); + x = find_variable_backward_with_token(hcl, fun_name, &vi); if (x <= -1) return -1; if (x == 0) { @@ -6003,15 +6008,15 @@ static HCL_INLINE int post_fun (hcl_t* hcl) switch (cf->u.fun.fun_type & 0xFF) { case FUN_CM: /* class method */ - SWITCH_TOP_CFRAME (hcl, COP_EMIT_CLASS_CMSTORE, defun_name); + SWITCH_TOP_CFRAME (hcl, COP_EMIT_CLASS_CMSTORE, fun_name); break; case FUN_CIM: /* class instantiation method */ - SWITCH_TOP_CFRAME (hcl, COP_EMIT_CLASS_CIMSTORE, defun_name); + SWITCH_TOP_CFRAME (hcl, COP_EMIT_CLASS_CIMSTORE, fun_name); break; case FUN_IM: /* instance method */ - SWITCH_TOP_CFRAME (hcl, COP_EMIT_CLASS_IMSTORE, defun_name); + SWITCH_TOP_CFRAME (hcl, COP_EMIT_CLASS_IMSTORE, fun_name); break; default: @@ -6024,7 +6029,7 @@ static HCL_INLINE int post_fun (hcl_t* hcl) } else { - hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAMEDUP, HCL_CNODE_GET_LOC(defun_name), HCL_CNODE_GET_TOK(defun_name), "duplicate method name"); + hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAMEDUP, HCL_CNODE_GET_LOC(fun_name), HCL_CNODE_GET_TOK(fun_name), "duplicate method name"); return -1; } } @@ -6032,17 +6037,17 @@ static HCL_INLINE int post_fun (hcl_t* hcl) { /* the function name must be global or module-wide.(no module implemented yet. so only global) */ #if 0 - x = find_variable_backward_with_token(hcl, defun_name, &vi); + x = find_variable_backward_with_token(hcl, fun_name, &vi); if (x <= -1) return -1; if (x == 0) { - SWITCH_TOP_CFRAME (hcl, COP_EMIT_SET, defun_name); + SWITCH_TOP_CFRAME (hcl, COP_EMIT_SET, fun_name); cf = GET_TOP_CFRAME(hcl); cf->u.set.vi.type = VAR_NAMED; } else { - SWITCH_TOP_CFRAME (hcl, COP_EMIT_SET, defun_name); + SWITCH_TOP_CFRAME (hcl, COP_EMIT_SET, fun_name); cf = GET_TOP_CFRAME(hcl); cf->u.set.vi = vi; } @@ -6063,7 +6068,7 @@ static HCL_INLINE int post_fun (hcl_t* hcl) if (emit_byte_instruction(hcl, HCL_CODE_CLASS_LOAD, HCL_CNODE_GET_LOC(class_name)) <= -1) return -1; /* the function name is always named */ - lit = hcl_makesymbol(hcl, HCL_CNODE_GET_TOKPTR(defun_name), HCL_CNODE_GET_TOKLEN(defun_name)); + lit = hcl_makesymbol(hcl, HCL_CNODE_GET_TOKPTR(fun_name), HCL_CNODE_GET_TOKLEN(fun_name)); if (HCL_UNLIKELY(!lit)) return -1; if (add_literal(hcl, lit, &index) <= -1) return -1; @@ -6088,14 +6093,14 @@ static HCL_INLINE int post_fun (hcl_t* hcl) return -1; } - if (emit_single_param_instruction(hcl, inst, index, HCL_CNODE_GET_LOC(defun_name)) <= -1) return -1; + if (emit_single_param_instruction(hcl, inst, index, HCL_CNODE_GET_LOC(fun_name)) <= -1) return -1; if (emit_byte_instruction(hcl, HCL_CODE_CLASS_EXIT, HCL_CNODE_GET_LOC(class_name)) <= -1) return -1; POP_CFRAME (hcl); } else { /* An explicitly named function is always global */ - SWITCH_TOP_CFRAME (hcl, COP_EMIT_SET, defun_name); + SWITCH_TOP_CFRAME (hcl, COP_EMIT_SET, fun_name); cf = GET_TOP_CFRAME(hcl); cf->u.set.vi.type = VAR_NAMED; cf->u.set.mode = VAR_ACCESS_STORE; @@ -6310,7 +6315,7 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags) /* * In the non-INTERACTIVE mode, the literal frame base(lfbase) doesn't matter. * Only the initial function object contains the literal frame. - * No other function objects are created. All 'defun/fun' defintions are + * No other function objects are created. All 'fun' defintions are * translated to block context objects instead. * * In the INTERACTIVE mode, the literal frame base(lfbase) plays a key role. @@ -6319,7 +6324,7 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags) * reference part of the literal frame reserved for a function. * * (set b 1) - * (defun set-a(x) (set a x)) + * (fun set-a(x) (set a x)) * (set a 2) * (set-a 4) * (printf "%d\n" a) @@ -6331,7 +6336,7 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags) * @3 (printf . #) * @4 "%d\n" * - * @1 to @2 will be copied to a function object when defun is executed. + * @1 to @2 will be copied to a function object when fun is executed. * The literal frame of the created function object for set-a looks * like this * @0 (a) diff --git a/lib/gc.c b/lib/gc.c index 618dd9b..5222a65 100644 --- a/lib/gc.c +++ b/lib/gc.c @@ -43,7 +43,6 @@ static struct { 5, { 'c','l','a','s','s' }, HCL_SYNCODE_CLASS, HCL_OFFSETOF(hcl_t,s_class) }, { 8, { 'c','o','n','t','i','n','u','e' }, HCL_SYNCODE_CONTINUE, HCL_OFFSETOF(hcl_t,s_continue) }, { 8, { 'd','e','f','c','l','a','s','s' }, HCL_SYNCODE_DEFCLASS, HCL_OFFSETOF(hcl_t,s_defclass) }, - { 5, { 'd','e','f','u','n' }, HCL_SYNCODE_DEFUN, HCL_OFFSETOF(hcl_t,s_defun) }, { 2, { 'd','o' }, HCL_SYNCODE_DO, HCL_OFFSETOF(hcl_t,s_do) }, { 4, { 'e','l','i','f' }, HCL_SYNCODE_ELIF, HCL_OFFSETOF(hcl_t,s_elif) }, { 4, { 'e','l','s','e' }, HCL_SYNCODE_ELSE, HCL_OFFSETOF(hcl_t,s_else) }, diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index 9c10e6c..837c531 100644 --- a/lib/hcl-prv.h +++ b/lib/hcl-prv.h @@ -1415,8 +1415,6 @@ enum hcl_bcode_t HCL_CODE_NOOP = 0xFF /* 255 */ }; - - typedef hcl_ooi_t (*hcl_outbfmt_t) ( hcl_t* hcl, hcl_bitmask_t mask, @@ -1439,6 +1437,23 @@ typedef hcl_ooi_t (*hcl_outbfmt_t) ( (c >= 'A' && c <= 'Z')? ((c - 'A' + 10 < base)? (c - 'A' + 10): base): \ (c >= 'a' && c <= 'z')? ((c - 'a' + 10 < base)? (c - 'a' + 10): base): base) + +/* receiver check failure leads to hard failure. + * RATIONAL: the primitive handler should be used by relevant classes and + * objects only. if the receiver check fails, you must review + * your class library */ +#define HCL_PF_CHECK_RCV(hcl,cond) do { \ + if (!(cond)) { hcl_seterrnum((hcl), HCL_EMSGRCV); return HCL_PF_HARD_FAILURE; } \ +} while(0) + +/* argument check failure causes the wrapping method to return an error. + * RATIONAL: Being a typeless language, it's hard to control the kinds of + * arguments. + */ +#define HCL_PF_CHECK_ARGS(hcl,nargs,cond) do { \ + if (!(cond)) { hcl_seterrnum (hcl, HCL_EINVAL); return HCL_PF_FAILURE; } \ +} while(0) + #if defined(__cplusplus) extern "C" { #endif diff --git a/lib/hcl.h b/lib/hcl.h index c61df47..d89a6ef 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -2055,7 +2055,6 @@ enum hcl_syncode_t HCL_SYNCODE_CLASS, HCL_SYNCODE_CONTINUE, HCL_SYNCODE_DEFCLASS, - HCL_SYNCODE_DEFUN, HCL_SYNCODE_DO, HCL_SYNCODE_ELIF, HCL_SYNCODE_ELSE, @@ -3352,6 +3351,26 @@ HCL_EXPORT void hcl_assertfailed ( hcl_oow_t line ); + +/* ========================================================================= + * HELPERS + * ========================================================================= */ +HCL_EXPORT void hcl_start_ticker ( + void +); + +HCL_EXPORT void hcl_stop_ticker ( + void +); + +HCL_EXPORT void hcl_catch_termreq ( + void +); + +HCL_EXPORT void hcl_uncatch_termreq ( + void +); + #if defined(__cplusplus) } #endif diff --git a/lib/prim.c b/lib/prim.c index 9c15e7a..ad5212f 100644 --- a/lib/prim.c +++ b/lib/prim.c @@ -1227,6 +1227,48 @@ static hcl_pfrc_t pf_object_new (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs) /* ------------------------------------------------------------------------- */ +static hcl_pfrc_t pf_system_get_sigfd (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs) +{ + hcl_ooi_t fd; + fd = hcl->vmprim.vm_getsigfd(hcl); + HCL_STACK_SETRET (hcl, nargs, HCL_SMOOI_TO_OOP(fd)); + return HCL_PF_SUCCESS; +} + +static hcl_pfrc_t pf_system_get_sig (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs) +{ + hcl_uint8_t sig; + int n; + + n = hcl->vmprim.vm_getsig(hcl, &sig); + if (n <= -1) return HCL_PF_FAILURE; + + if (n == 0) HCL_STACK_SETRETTOERROR (hcl, nargs, HCL_ENOENT); + else HCL_STACK_SETRET (hcl, nargs, HCL_SMOOI_TO_OOP((hcl_ooi_t)sig)); + + return HCL_PF_SUCCESS; +} + +static hcl_pfrc_t pf_system_set_sig (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs) +{ + hcl_oop_t tmp; + hcl_uint8_t sig; + int n; + + tmp = HCL_STACK_GETARG(hcl, nargs, 0); + HCL_PF_CHECK_ARGS (hcl, nargs, HCL_OOP_IS_SMOOI(tmp)); + + sig = (hcl_uint8_t)HCL_OOP_TO_SMOOI(tmp); + n = hcl->vmprim.vm_setsig(hcl, sig); + if (n <= -1) return HCL_PF_FAILURE; + + HCL_STACK_SETRET (hcl, nargs, HCL_SMOOI_TO_OOP((hcl_ooi_t)sig)); + + return HCL_PF_SUCCESS; +} + +/* ------------------------------------------------------------------------- */ + static pf_t builtin_prims[] = { /* TODO: move these primitives to modules... */ @@ -1240,6 +1282,10 @@ static pf_t builtin_prims[] = { 1, HCL_TYPE_MAX(hcl_oow_t), pf_scanf, 5, { 's','c','a','n','f' } }, { 1, HCL_TYPE_MAX(hcl_oow_t), pf_sprintf, 7, { 's','p','r','i','n','t','f' } }, + { 0, 0, pf_system_get_sigfd,16, { 's','y','s','t','e','m','-','g','e','t','-','s','i','g','f','d' } }, + { 0, 0, pf_system_get_sig, 14, { 's','y','s','t','e','m','-','g','e','t','-','s','i','g' } }, + { 1, 1, pf_system_set_sig, 14, { 's','y','s','t','e','m','-','s','e','t','-','s','i','g' } }, + { 0, 0, pf_gc, 2, { 'g','c' } }, { 1, 1, pf_not, 3, { 'n','o','t' } }, diff --git a/lib/read.c b/lib/read.c index a834355..ca92566 100644 --- a/lib/read.c +++ b/lib/read.c @@ -661,7 +661,7 @@ static HCL_INLINE hcl_cnode_t* leave_list (hcl_t* hcl, hcl_loc_t* list_loc, int* else if (lval && HCL_CNODE_IS_CONS_CONCODED(lval, HCL_CONCODE_TUPLE)) { /* - * defun f(a :: b c) { b := (a + 10); c := (a + 20) } + * fun f(a :: b c) { b := (a + 10); c := (a + 20) } * [x, y] := (f 9) ## this kind of expression - translate to set-r x y (f 9) */ hcl_cnode_t* tmp; @@ -888,13 +888,12 @@ static HCL_INLINE int can_colon_list (hcl_t* hcl) else if (!(rstl->flagv & JSON)) { /* handling of a colon sign in out-of-class instance method definition. - * e.g. defun String:length() { return (str.length self). } + * e.g. fun String:length() { return (str.length self). } * TODO: inject a symbol ':' to differentiate form '::' or ':*' methods. * these class methods and class instantiation methods are supposed to be * implemented elsewhere because ':' has dual use while '::' or ':*' are * independent tokens */ - if (HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(rstl->head), HCL_SYNCODE_DEFUN) || - HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(rstl->head), HCL_SYNCODE_FUN) || + if (HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(rstl->head), HCL_SYNCODE_FUN) || HCL_CNODE_IS_TYPED(HCL_CNODE_CONS_CAR(rstl->head), HCL_CNODE_FUN)) { if (rstl->count == 2) return 2; @@ -909,8 +908,8 @@ static HCL_INLINE int can_colon_list (hcl_t* hcl) cc = (hcl_concode_t)LIST_FLAG_GET_CONCODE(rstl->flagv); if (cc == HCL_CONCODE_XLIST) { - /* method defintion with defun - e.g. defun String:length() - * ugly that this reader must know about the meaning of defun */ + /* method defintion with fun - e.g. fun String:length() + * ugly that this reader must know about the meaning of fun */ if (rstl->count > 1) return 0; /* ugly dual use of a colon sign. switch to MLIST if the first element * is delimited by a colon. e.g. (obj:new 10 20 30) */ @@ -1587,7 +1586,7 @@ static int feed_process_token (hcl_t* hcl) * for example, '(+ 10 20)' as a leading expression is like '((+ 10 20))'. * ------------------------------------------------------------- * It is useful but a bit confusing: - * defun x(a) { return (fun(b) { return (+ a b) }) } + * fun x(a) { return (fun(b) { return (+ a b) }) } * printf "%d\n" ((x 10) 20) ## excplicit outer () is required here * (x 10) 30 ## explicit outer () must not be used here * j := ((x 10) 40) ## explicit outer () is required here diff --git a/t/class-5001.err b/t/class-5001.err index 9451911..e17ff9e 100644 --- a/t/class-5001.err +++ b/t/class-5001.err @@ -18,11 +18,11 @@ class B + ##ERROR: syntax error - prohibited binary selector '+' J := 11 class B { if (== J 10) { - defun :*newA() { + fun :*newA() { return self } } else { - defun :*newB() { + fun :*newB() { return self } } diff --git a/t/feed-01.hcl b/t/feed-01.hcl index ec029ac..03d668b 100644 --- a/t/feed-01.hcl +++ b/t/feed-01.hcl @@ -4,7 +4,7 @@ | J | -defun xxx (x y z +fun xxx (x y z :: r ) { | k diff --git a/t/feed-5001.err b/t/feed-5001.err index fad872e..326698e 100644 --- a/t/feed-5001.err +++ b/t/feed-5001.err @@ -134,13 +134,13 @@ printf :*; ##ERROR: syntax error - prohibited in this context --- -defun :: fun1() { ##ERROR: syntax error - function name not symbol in defun +fun :: fun1() { ##ERROR: syntax error - invalid function name '::' for 'fun' return 10; }; --- -defun :* fun1() { ##ERROR: syntax error - function name not symbol in defun +fun :* fun1() { ##ERROR: syntax error - invalid function name ':*' for 'fun' return 10; }; diff --git a/t/fun-01.hcl b/t/fun-01.hcl index b1e1897..9ca1aec 100644 --- a/t/fun-01.hcl +++ b/t/fun-01.hcl @@ -1,4 +1,4 @@ -defun aaa(a b) { +fun aaa(a b) { | c | set c (+ a b); return c; @@ -14,13 +14,13 @@ if (== k 30) { ## -------------------------------------- -defun mkfun(t) { +fun mkfun(t) { return (fun(c) { return (+ t c); }); } -defun mkfun2(t) { +fun mkfun2(t) { return {fun(c) { return (fun(d) { return (+ d c t) @@ -64,7 +64,7 @@ if (== k 80) { ## -------------------------------------- ## multiple return values -defun f(a :: b c) { b := (+ a 10); c := (+ a 20) } +fun f(a :: b c) { b := (+ a 10); c := (+ a 20) } [x, y] := (f 9) if (== x 19) { printf "OK - %d\n" x @@ -78,7 +78,7 @@ if (== y 29) { } ## -------------------------------------- -k := (defun qq(t) (+ t 20)) +k := (fun qq(t) (+ t 20)) x := (k 8) y := (qq 9) @@ -97,16 +97,16 @@ if (== y 29) { ## -------------------------------------- defclass A [ a b c ] { - defun :* newInstance(x y z) { + fun :* newInstance(x y z) { set a x set b y set c z return self }; - defun get-a() { return a; }; - ##defun get-b() b; - ##defun get-c() c; + fun get-a() { return a; }; + ##fun get-b() b; + ##fun get-c() c; }; k := (A:newInstance 11 22 33); diff --git a/t/insta-01.hcl b/t/insta-01.hcl index 9cda6c5..3a1c43f 100644 --- a/t/insta-01.hcl +++ b/t/insta-01.hcl @@ -14,21 +14,21 @@ fun Number: ~= (oprnd) { return (~= self oprnd) } class A [ a b c ] { - defun :*newInstance(x y z) { + fun :*newInstance(x y z) { set a x; set b y; set c z; return self; }; - defun get-a() { return self.a; }; - defun get-b() { return self.b; }; - defun get-c() { return self.c; }; + fun get-a() { return self.a; }; + fun get-b() { return self.b; }; + fun get-c() { return self.c; }; }; class B :: A [ d e f ] { - defun :*newInstance(x y z) { + fun :*newInstance(x y z) { super:newInstance (* x 2) (* y 2) (* z 2); set d x; set e y; @@ -36,11 +36,11 @@ class B :: A [ d e f ] { return self; }; - defun :: getSuper() { return super; }; - ###defun :: getSuperclass() { return (self:superclass); }; - defun :: getSelf() { return self; }; + fun :: getSuper() { return super; }; + ###fun :: getSuperclass() { return (self:superclass); }; + fun :: getSelf() { return self; }; - defun sum() { + fun sum() { return (+ (super:get-a) (super:get-b) (super:get-c) self.d self.e self.f); }; }; diff --git a/t/insta-02.hcl b/t/insta-02.hcl index d901c20..f547487 100644 --- a/t/insta-02.hcl +++ b/t/insta-02.hcl @@ -12,8 +12,8 @@ fun Number: ~= (oprnd) { return (~= self oprnd) } ## -------------------------------------------------------------- set t ( class [ x ] { - defun :* make() { x := 1234; return self; }; - defun get-x() { return x }; + fun :* make() { x := 1234; return self; }; + fun get-x() { return x }; } ); diff --git a/t/proc-01.hcl b/t/proc-01.hcl index 3b05cb3..f95d480 100644 --- a/t/proc-01.hcl +++ b/t/proc-01.hcl @@ -1,7 +1,7 @@ z1 := 0 z2 := 0 -defun loop1() { +fun loop1() { | k | k := 1 @@ -15,7 +15,7 @@ defun loop1() { sem-signal s1 } -defun loop2() { +fun loop2() { | k | k := 0 diff --git a/t/retvar-01.hcl b/t/retvar-01.hcl index 5862b63..65c2fb8 100644 --- a/t/retvar-01.hcl +++ b/t/retvar-01.hcl @@ -6,7 +6,7 @@ set i 100; - defun ff(a b :: x y z) { + fun ff(a b :: x y z) { set x (+ a b i); set y (+ x x); set z (+ 999 i); @@ -36,12 +36,12 @@ set X1 999; set X2 888; - defun :: get ( :: x y) { + fun :: get ( :: x y) { set x X1; set y X2; }; - defun :: get2 (inc :: x y) { + fun :: get2 (inc :: x y) { set x (+ X1 inc); set y (+ X2 inc); }; diff --git a/t/va-01.hcl b/t/va-01.hcl index 1e7007e..13caead 100644 --- a/t/va-01.hcl +++ b/t/va-01.hcl @@ -1,4 +1,4 @@ -defun fn-y (t1 t2 va-ctx) { +fun fn-y (t1 t2 va-ctx) { | i | i := 0 while (< i (va-count va-ctx)) { @@ -7,7 +7,7 @@ defun fn-y (t1 t2 va-ctx) { } } -defun x(a b ... :: x y z) { +fun x(a b ... :: x y z) { |i| x := (va-count) diff --git a/t/var-01.hcl b/t/var-01.hcl index 1d71d5b..ea2b9b0 100644 --- a/t/var-01.hcl +++ b/t/var-01.hcl @@ -1,4 +1,4 @@ -defun x (a b :: r) { +fun x (a b :: r) { | x y | @@ -30,7 +30,7 @@ if (~= t 500) (printf "ERROR: t is not equal to 500\n") \ else (printf "OK: %d\n" t) -defun x () { +fun x () { | x y | @@ -58,17 +58,17 @@ x class T [ j ] { - defun :* new() { + fun :* new() { set j 99 return self } - defun x() { + fun x() { set R { | x | set x 1 while (< x j) { - defun Q() x + fun Q() x set x (+ x 1) } } diff --git a/t/var-02.hcl b/t/var-02.hcl index 5308889..fe9a820 100644 --- a/t/var-02.hcl +++ b/t/var-02.hcl @@ -1,4 +1,4 @@ -defun x (a :: x y z) { +fun x (a :: x y z) { x := (* a a); y := (+ a a); z := (- x y); diff --git a/t/var-5001.err b/t/var-5001.err index cc3042c..39353dc 100644 --- a/t/var-5001.err +++ b/t/var-5001.err @@ -1,5 +1,5 @@ defclass A [ a ] { - defun :* init1() { + fun :* init1() { | b | set b (+ 1 2); set a b; @@ -15,7 +15,7 @@ defclass A [ a ] { printf ">>> %d\n" j; } - defun :* init2() { + fun :* init2() { | b | set b (+ 10 20); set a b; @@ -26,7 +26,7 @@ defclass A [ a ] { --- -defun String length() { ##ERROR: syntax error - no argument list +fun String length() { ##ERROR: syntax error - no argument list } --- diff --git a/t/var-5004.err b/t/var-5004.err index f2d3b16..464a1f7 100644 --- a/t/var-5004.err +++ b/t/var-5004.err @@ -1,2 +1,2 @@ -defun self.x() { ##ERROR: syntax error - function name not symbol +fun self.x() { ##ERROR: syntax error - invalid function name 'self.x' for 'fun' };