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

let 'fun' replace 'defun' totally
All checks were successful
continuous-integration/drone/push Build is passing
Details

Browse Source
This commit is contained in:
hyung-hwan 2024-09-28 11:57:56 +09:00
parent b108cc79e7
commit f6d97f8301
19 changed files with 203 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

139
lib/comp.c
View File

@ -69,16 +69,16 @@ enum
/* -------------------------------------------- /* --------------------------------------------
(defun plus(x y) (fun plus(x y)
(printf "plus %d %d\n" x y) (printf "plus %d %d\n" x y)
(defun minus(x y) (fun minus(x y)
(printf "minus %d %d\n" x y) (printf "minus %d %d\n" x y)
(- x y) (- x y)
) )
(+ x y) (+ x y)
) )
(defun dummy(q) (fun dummy(q)
(printf "%s\n" q) (printf "%s\n" q)
) )
@ -2492,7 +2492,7 @@ static HCL_INLINE int compile_else (hcl_t* hcl)
(set x 20) (set x 20)
(printf "normal statement ....\n"); (printf "normal statement ....\n");
(defun new (a b c) (fun new (a b c)
(printf "%O\n" self) ; self is A (printf "%O\n" self) ; self is A
(set obj super.new) (set obj super.new)
(obj.init a b c) (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_cnode_t* cmd, * obj, * args;
hcl_oow_t va, nargs, nrvars, nlvars; hcl_oow_t va, nargs, nrvars, nlvars;
hcl_ooi_t jump_inst_pos, lfbase_pos, lfsize_pos; hcl_ooi_t jump_inst_pos, lfbase_pos, lfsize_pos;
hcl_oow_t saved_tv_wcount, tv_dup_start; 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_cnode_t* class_name;
hcl_cframe_t* cf; hcl_cframe_t* cf;
unsigned int fun_type = FUN_PLAIN; unsigned int fun_type = FUN_PLAIN;
int named = 0;
HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src)); HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src));
saved_tv_wcount = hcl->c->tv.wcount; saved_tv_wcount = hcl->c->tv.wcount;
cmd = HCL_CNODE_CONS_CAR(src); cmd = HCL_CNODE_CONS_CAR(src);
obj = HCL_CNODE_CONS_CDR(src); obj = HCL_CNODE_CONS_CDR(src);
class_name = HCL_NULL; 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 /* inaccurate pre-check if 'fun' is followed by an argument list
* without a function name. stop-gap measure to support 'fun' in place of 'defun' */ * without a function name. */
HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(cmd, HCL_SYNCODE_FUN) || HCL_CNODE_IS_TYPED(cmd, HCL_CNODE_FUN));
args = HCL_CNODE_CONS_CAR(obj); args = HCL_CNODE_CONS_CAR(obj);
if (!HCL_CNODE_IS_ELIST_CONCODED(args, HCL_CONCODE_XLIST) && if (!HCL_CNODE_IS_ELIST_CONCODED(args, HCL_CONCODE_XLIST) &&
!HCL_CNODE_IS_CONS_CONCODED(args, HCL_CONCODE_XLIST)) !HCL_CNODE_IS_CONS_CONCODED(args, HCL_CONCODE_XLIST))
{ {
/* not followed by an argument list */ /* not followed by an argument list */
defun = 1; named = 1;
goto fun_as_defun; goto named_function;
} }
} }
if (defun) if (named)
{ {
/* defun must be followed by an explicit function name */ named_function:
HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(cmd, HCL_SYNCODE_DEFUN));
fun_as_defun:
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_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; return -1;
} }
defun_name = HCL_CNODE_CONS_CAR(obj); fun_name = HCL_CNODE_CONS_CAR(obj);
if (is_in_class_init_scope(hcl)) 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 method - (fun ::xxxx () ...) inside class definition */
/* class instantiation method - (defun :*xxxx() ...) inside class definition */ /* class instantiation method - (fun :*xxxx() ...) inside class definition */
obj = HCL_CNODE_CONS_CDR(obj); obj = HCL_CNODE_CONS_CDR(obj);
if (!obj) if (!obj)
{ {
@ -2879,14 +2878,14 @@ static int compile_fun (hcl_t* hcl, hcl_cnode_t* src, int defun)
return -1; return -1;
} }
fun_type = HCL_CNODE_IS_DBLCOLONS(defun_name)? FUN_CM: FUN_CIM; fun_type = HCL_CNODE_IS_DBLCOLONS(fun_name)? FUN_CM: FUN_CIM;
defun_name = HCL_CNODE_CONS_CAR(obj); /* advance to the actual name */ fun_name = HCL_CNODE_CONS_CAR(obj); /* advance to the actual name */
} }
else 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 */ * the class name must not be specified in the class initialization scope */
hcl_cnode_t* tmp; hcl_cnode_t* tmp;
tmp = HCL_CNODE_CONS_CDR(obj); 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_setsynerrbfmt (
hcl, HCL_SYNERR_VARNAME, 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", "function name not valid followed by %.*js",
HCL_CNODE_GET_TOKLEN(tmp), HCL_CNODE_GET_TOKPTR(tmp)); HCL_CNODE_GET_TOKLEN(tmp), HCL_CNODE_GET_TOKPTR(tmp));
return -1; return -1;
@ -2908,7 +2907,7 @@ static int compile_fun (hcl_t* hcl, hcl_cnode_t* src, int defun)
fun_type = FUN_IM; 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; hcl_cnode_t* tmp, marker;
tmp = HCL_CNODE_CONS_CDR(obj); 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)) if (HCL_CNODE_IS_SYMBOL_PLAIN(cand))
{ {
/* out-of-class method definition /* out-of-class method definition
* for defun String:length() { ... }, * for fun String:length() { ... },
* class_name is String, defun_name is length. */ * class_name is String, fun_name is length. */
fun_type = HCL_CNODE_IS_DBLCOLONS(marker)? FUN_CM: fun_type = HCL_CNODE_IS_DBLCOLONS(marker)? FUN_CM:
HCL_CNODE_IS_COLONSTAR(marker)? FUN_CIM: FUN_IM; 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; fun_type |= 0x100;
class_name = defun_name; class_name = fun_name;
defun_name = HCL_CNODE_CONS_CAR(tmp); fun_name = HCL_CNODE_CONS_CAR(tmp);
obj = 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; 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; return -1;
} }
@ -2969,14 +2975,17 @@ static int compile_fun (hcl_t* hcl, hcl_cnode_t* src, int defun)
} }
else else
{ {
HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(cmd, HCL_SYNCODE_FUN) || HCL_CNODE_IS_TYPED(cmd, HCL_CNODE_FUN)); HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(cmd, HCL_SYNCODE_FUN) ||
defun_name = HCL_NULL; HCL_CNODE_IS_TYPED(cmd, HCL_CNODE_FUN));
fun_name = HCL_NULL;
} }
if (!obj) if (!obj)
{ {
no_arg_list: 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; return -1;
} }
else if (!HCL_CNODE_IS_CONS(obj)) 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) { ... }; * fun aa(a b) { ... };
* (defun aa(a b) { ... }) * (fun aa(a b) { ... })
* *
* the block expression must be the first and the only expression at the body position. * 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. * 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; 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 */ 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 = GET_SUBCFRAME(hcl);
cf->u.fun.fun_type = fun_type; cf->u.fun.fun_type = fun_type;
cf->u.fun.class_name = class_name; 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)) * (set_r a b c (f 1 2))
* *
* the call to f * 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)) * ([a b c] := (f 1 2))
* *
* the call to f * 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; goto done;
case HCL_CNODE_FUN: case HCL_CNODE_FUN:
if (compile_fun(hcl, obj, 0) <= -1) return -1; if (compile_fun(hcl, obj) <= -1) return -1;
goto done; goto done;
case HCL_CNODE_DO: 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; if (compile_class(hcl, obj, 1) <= -1) return -1;
break; break;
case HCL_SYNCODE_DEFUN:
if (compile_fun(hcl, obj, 1) <= -1) return -1;
break;
case HCL_SYNCODE_DO: case HCL_SYNCODE_DO:
if (compile_do(hcl, obj) <= -1) return -1; if (compile_do(hcl, obj) <= -1) return -1;
break; break;
@ -4166,7 +4171,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj, int nret
case HCL_SYNCODE_FUN: case HCL_SYNCODE_FUN:
/* (fun (x y) (+ x y)) */ /* (fun (x y) (+ x y)) */
if (compile_fun(hcl, obj, 0) <= -1) return -1; if (compile_fun(hcl, obj) <= -1) return -1;
break; break;
case HCL_SYNCODE_OR: case HCL_SYNCODE_OR:
@ -5969,19 +5974,19 @@ static HCL_INLINE int post_fun (hcl_t* hcl)
if (cf->operand) 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 | * | t1 t2 x |
* (set x 10) ; this x refers to the local variable. * (set x 10) ; this x refers to the local variable.
* ) * )
* *
* the block has been exited(blk.depth--) before finding 'x' in the outer scope. * 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_cnode_t* class_name = cf->u.fun.class_name;
hcl_var_info_t vi; hcl_var_info_t vi;
int x; 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)) if (is_in_class_init_scope(hcl))
{ {
@ -5995,7 +6000,7 @@ static HCL_INLINE int post_fun (hcl_t* hcl)
return -1; 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 <= -1) return -1;
if (x == 0) if (x == 0)
{ {
@ -6003,15 +6008,15 @@ static HCL_INLINE int post_fun (hcl_t* hcl)
switch (cf->u.fun.fun_type & 0xFF) switch (cf->u.fun.fun_type & 0xFF)
{ {
case FUN_CM: /* class method */ 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; break;
case FUN_CIM: /* class instantiation method */ 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; break;
case FUN_IM: /* instance method */ 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; break;
default: default:
@ -6024,7 +6029,7 @@ static HCL_INLINE int post_fun (hcl_t* hcl)
} }
else 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; 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) */ /* the function name must be global or module-wide.(no module implemented yet. so only global) */
#if 0 #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 <= -1) return -1;
if (x == 0) 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 = GET_TOP_CFRAME(hcl);
cf->u.set.vi.type = VAR_NAMED; cf->u.set.vi.type = VAR_NAMED;
} }
else 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 = GET_TOP_CFRAME(hcl);
cf->u.set.vi = vi; 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; if (emit_byte_instruction(hcl, HCL_CODE_CLASS_LOAD, HCL_CNODE_GET_LOC(class_name)) <= -1) return -1;
/* the function name is always named */ /* 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 (HCL_UNLIKELY(!lit)) return -1;
if (add_literal(hcl, lit, &index) <= -1) 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; 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; if (emit_byte_instruction(hcl, HCL_CODE_CLASS_EXIT, HCL_CNODE_GET_LOC(class_name)) <= -1) return -1;
POP_CFRAME (hcl); POP_CFRAME (hcl);
} }
else else
{ {
/* An explicitly named function is always global */ /* 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 = GET_TOP_CFRAME(hcl);
cf->u.set.vi.type = VAR_NAMED; cf->u.set.vi.type = VAR_NAMED;
cf->u.set.mode = VAR_ACCESS_STORE; 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. * In the non-INTERACTIVE mode, the literal frame base(lfbase) doesn't matter.
* Only the initial function object contains the literal frame. * 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. * translated to block context objects instead.
* *
* In the INTERACTIVE mode, the literal frame base(lfbase) plays a key role. * 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. * reference part of the literal frame reserved for a function.
* *
* (set b 1) * (set b 1)
* (defun set-a(x) (set a x)) * (fun set-a(x) (set a x))
* (set a 2) * (set a 2)
* (set-a 4) * (set-a 4)
* (printf "%d\n" a) * (printf "%d\n" a)
@ -6331,7 +6336,7 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags)
* @3 (printf . #<PRIM>) * @3 (printf . #<PRIM>)
* @4 "%d\n" * @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 * The literal frame of the created function object for set-a looks
* like this * like this
* @0 (a) * @0 (a)

1
lib/gc.c
View File

@ -43,7 +43,6 @@ static struct
{ 5, { 'c','l','a','s','s' }, HCL_SYNCODE_CLASS, HCL_OFFSETOF(hcl_t,s_class) }, { 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, { '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) }, { 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) }, { 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','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) }, { 4, { 'e','l','s','e' }, HCL_SYNCODE_ELSE, HCL_OFFSETOF(hcl_t,s_else) },

19
lib/hcl-prv.h
View File

@ -1415,8 +1415,6 @@ enum hcl_bcode_t
HCL_CODE_NOOP = 0xFF /* 255 */ HCL_CODE_NOOP = 0xFF /* 255 */
}; };
typedef hcl_ooi_t (*hcl_outbfmt_t) ( typedef hcl_ooi_t (*hcl_outbfmt_t) (
hcl_t* hcl, hcl_t* hcl,
hcl_bitmask_t mask, 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): \
(c >= 'a' && c <= 'z')? ((c - 'a' + 10 < base)? (c - 'a' + 10): base): 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) #if defined(__cplusplus)
extern "C" { extern "C" {
#endif #endif

21
lib/hcl.h
View File

@ -2055,7 +2055,6 @@ enum hcl_syncode_t
HCL_SYNCODE_CLASS, HCL_SYNCODE_CLASS,
HCL_SYNCODE_CONTINUE, HCL_SYNCODE_CONTINUE,
HCL_SYNCODE_DEFCLASS, HCL_SYNCODE_DEFCLASS,
HCL_SYNCODE_DEFUN,
HCL_SYNCODE_DO, HCL_SYNCODE_DO,
HCL_SYNCODE_ELIF, HCL_SYNCODE_ELIF,
HCL_SYNCODE_ELSE, HCL_SYNCODE_ELSE,
@ -3352,6 +3351,26 @@ HCL_EXPORT void hcl_assertfailed (
hcl_oow_t line 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) #if defined(__cplusplus)
} }
#endif #endif

46
lib/prim.c
View File

@ -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[] = static pf_t builtin_prims[] =
{ {
/* TODO: move these primitives to modules... */ /* 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_scanf, 5, { 's','c','a','n','f' } },
{ 1, HCL_TYPE_MAX(hcl_oow_t), pf_sprintf, 7, { 's','p','r','i','n','t','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' } }, { 0, 0, pf_gc, 2, { 'g','c' } },
{ 1, 1, pf_not, 3, { 'n','o','t' } }, { 1, 1, pf_not, 3, { 'n','o','t' } },

13
lib/read.c
View File

@ -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)) 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) * [x, y] := (f 9) ## this kind of expression - translate to set-r x y (f 9)
*/ */
hcl_cnode_t* tmp; hcl_cnode_t* tmp;
@ -888,13 +888,12 @@ static HCL_INLINE int can_colon_list (hcl_t* hcl)
else if (!(rstl->flagv & JSON)) else if (!(rstl->flagv & JSON))
{ {
/* handling of a colon sign in out-of-class instance method definition. /* 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. * TODO: inject a symbol ':' to differentiate form '::' or ':*' methods.
* these class methods and class instantiation methods are supposed to be * these class methods and class instantiation methods are supposed to be
* implemented elsewhere because ':' has dual use while '::' or ':*' are * implemented elsewhere because ':' has dual use while '::' or ':*' are
* independent tokens */ * independent tokens */
if (HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(rstl->head), HCL_SYNCODE_DEFUN) || if (HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(rstl->head), HCL_SYNCODE_FUN) ||
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)) HCL_CNODE_IS_TYPED(HCL_CNODE_CONS_CAR(rstl->head), HCL_CNODE_FUN))
{ {
if (rstl->count == 2) return 2; 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); cc = (hcl_concode_t)LIST_FLAG_GET_CONCODE(rstl->flagv);
if (cc == HCL_CONCODE_XLIST) if (cc == HCL_CONCODE_XLIST)
{ {
/* method defintion with defun - e.g. defun String:length() /* method defintion with fun - e.g. fun String:length()
* ugly that this reader must know about the meaning of defun */ * ugly that this reader must know about the meaning of fun */
if (rstl->count > 1) return 0; if (rstl->count > 1) return 0;
/* ugly dual use of a colon sign. switch to MLIST if the first element /* 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) */ * 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))'. * for example, '(+ 10 20)' as a leading expression is like '((+ 10 20))'.
* ------------------------------------------------------------- * -------------------------------------------------------------
* It is useful but a bit confusing: * 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 * printf "%d\n" ((x 10) 20) ## excplicit outer () is required here
* (x 10) 30 ## explicit outer () must not be used here * (x 10) 30 ## explicit outer () must not be used here
* j := ((x 10) 40) ## explicit outer () is required here * j := ((x 10) 40) ## explicit outer () is required here

4
t/class-5001.err
View File

@ -18,11 +18,11 @@ class B + ##ERROR: syntax error - prohibited binary selector '+'
J := 11 J := 11
class B { class B {
if (== J 10) { if (== J 10) {
defun :*newA() { fun :*newA() {
return self return self
} }
} else { } else {
defun :*newB() { fun :*newB() {
return self return self
} }
} }

2
t/feed-01.hcl
View File

@ -4,7 +4,7 @@
| J | | J |
defun xxx (x y z fun xxx (x y z
:: r ) { :: r ) {
| k | k

4
t/feed-5001.err
View File

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

18
t/fun-01.hcl
View File

@ -1,4 +1,4 @@
defun aaa(a b) { fun aaa(a b) {
| c | | c |
set c (+ a b); set c (+ a b);
return c; return c;
@ -14,13 +14,13 @@ if (== k 30) {
## -------------------------------------- ## --------------------------------------
defun mkfun(t) { fun mkfun(t) {
return (fun(c) { return (fun(c) {
return (+ t c); return (+ t c);
}); });
} }
defun mkfun2(t) { fun mkfun2(t) {
return {fun(c) { return {fun(c) {
return (fun(d) { return (fun(d) {
return (+ d c t) return (+ d c t)
@ -64,7 +64,7 @@ if (== k 80) {
## -------------------------------------- ## --------------------------------------
## multiple return values ## 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) [x, y] := (f 9)
if (== x 19) { if (== x 19) {
printf "OK - %d\n" x 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) x := (k 8)
y := (qq 9) y := (qq 9)
@ -97,16 +97,16 @@ if (== y 29) {
## -------------------------------------- ## --------------------------------------
defclass A [ a b c ] { defclass A [ a b c ] {
defun :* newInstance(x y z) { fun :* newInstance(x y z) {
set a x set a x
set b y set b y
set c z set c z
return self return self
}; };
defun get-a() { return a; }; fun get-a() { return a; };
##defun get-b() b; ##fun get-b() b;
##defun get-c() c; ##fun get-c() c;
}; };
k := (A:newInstance 11 22 33); k := (A:newInstance 11 22 33);

18
t/insta-01.hcl
View File

@ -14,21 +14,21 @@ fun Number: ~= (oprnd) { return (~= self oprnd) }
class A [ a b c ] { class A [ a b c ] {
defun :*newInstance(x y z) { fun :*newInstance(x y z) {
set a x; set a x;
set b y; set b y;
set c z; set c z;
return self; return self;
}; };
defun get-a() { return self.a; }; fun get-a() { return self.a; };
defun get-b() { return self.b; }; fun get-b() { return self.b; };
defun get-c() { return self.c; }; fun get-c() { return self.c; };
}; };
class B :: A [ d e f ] { class B :: A [ d e f ] {
defun :*newInstance(x y z) { fun :*newInstance(x y z) {
super:newInstance (* x 2) (* y 2) (* z 2); super:newInstance (* x 2) (* y 2) (* z 2);
set d x; set d x;
set e y; set e y;
@ -36,11 +36,11 @@ class B :: A [ d e f ] {
return self; return self;
}; };
defun :: getSuper() { return super; }; fun :: getSuper() { return super; };
###defun :: getSuperclass() { return (self:superclass); }; ###fun :: getSuperclass() { return (self:superclass); };
defun :: getSelf() { return self; }; fun :: getSelf() { return self; };
defun sum() { fun sum() {
return (+ (super:get-a) (super:get-b) (super:get-c) self.d self.e self.f); return (+ (super:get-a) (super:get-b) (super:get-c) self.d self.e self.f);
}; };
}; };

4
t/insta-02.hcl
View File

@ -12,8 +12,8 @@ fun Number: ~= (oprnd) { return (~= self oprnd) }
## -------------------------------------------------------------- ## --------------------------------------------------------------
set t ( set t (
class [ x ] { class [ x ] {
defun :* make() { x := 1234; return self; }; fun :* make() { x := 1234; return self; };
defun get-x() { return x }; fun get-x() { return x };
} }
); );

4
t/proc-01.hcl
View File

@ -1,7 +1,7 @@
z1 := 0 z1 := 0
z2 := 0 z2 := 0
defun loop1() { fun loop1() {
| k | | k |
k := 1 k := 1
@ -15,7 +15,7 @@ defun loop1() {
sem-signal s1 sem-signal s1
} }
defun loop2() { fun loop2() {
| k | | k |
k := 0 k := 0

6
t/retvar-01.hcl
View File

@ -6,7 +6,7 @@
set i 100; set i 100;
defun ff(a b :: x y z) { fun ff(a b :: x y z) {
set x (+ a b i); set x (+ a b i);
set y (+ x x); set y (+ x x);
set z (+ 999 i); set z (+ 999 i);
@ -36,12 +36,12 @@
set X1 999; set X1 999;
set X2 888; set X2 888;
defun :: get ( :: x y) { fun :: get ( :: x y) {
set x X1; set x X1;
set y X2; set y X2;
}; };
defun :: get2 (inc :: x y) { fun :: get2 (inc :: x y) {
set x (+ X1 inc); set x (+ X1 inc);
set y (+ X2 inc); set y (+ X2 inc);
}; };

4
t/va-01.hcl
View File

@ -1,4 +1,4 @@
defun fn-y (t1 t2 va-ctx) { fun fn-y (t1 t2 va-ctx) {
| i | | i |
i := 0 i := 0
while (< i (va-count va-ctx)) { 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| |i|
x := (va-count) x := (va-count)

10
t/var-01.hcl
View File

@ -1,4 +1,4 @@
defun x (a b :: r) { fun x (a b :: r) {
| x y | | x y |
@ -30,7 +30,7 @@ if (~= t 500) (printf "ERROR: t is not equal to 500\n") \
else (printf "OK: %d\n" t) else (printf "OK: %d\n" t)
defun x () { fun x () {
| x y | | x y |
@ -58,17 +58,17 @@ x
class T [ j ] { class T [ j ] {
defun :* new() { fun :* new() {
set j 99 set j 99
return self return self
} }
defun x() { fun x() {
set R { set R {
| x | | x |
set x 1 set x 1
while (< x j) { while (< x j) {
defun Q() x fun Q() x
set x (+ x 1) set x (+ x 1)
} }
} }

2
t/var-02.hcl
View File

@ -1,4 +1,4 @@
defun x (a :: x y z) { fun x (a :: x y z) {
x := (* a a); x := (* a a);
y := (+ a a); y := (+ a a);
z := (- x y); z := (- x y);

6
t/var-5001.err
View File

@ -1,5 +1,5 @@
defclass A [ a ] { defclass A [ a ] {
defun :* init1() { fun :* init1() {
| b | | b |
set b (+ 1 2); set b (+ 1 2);
set a b; set a b;
@ -15,7 +15,7 @@ defclass A [ a ] {
printf ">>> %d\n" j; printf ">>> %d\n" j;
} }
defun :* init2() { fun :* init2() {
| b | | b |
set b (+ 10 20); set b (+ 10 20);
set a b; 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
} }
--- ---

2
t/var-5004.err
View File

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