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)
(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 . #<PRIM>)
* @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)

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) },
{ 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) },

19
lib/hcl-prv.h
View File

@ -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

21
lib/hcl.h
View File

@ -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

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[] =
{
/* 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' } },

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))
{
/*
* 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

4
t/class-5001.err
View File

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

2
t/feed-01.hcl
View File

@ -4,7 +4,7 @@
| J |
defun xxx (x y z
fun xxx (x y z
:: r ) {
| 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;
};
---
defun :* fun1() { ##ERROR: syntax error - function name not symbol in defun
fun :* fun1() { ##ERROR: syntax error - invalid function name ':*' for 'fun'
return 10;
};

18
t/fun-01.hcl
View File

@ -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);

18
t/insta-01.hcl
View File

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

4
t/insta-02.hcl
View File

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

4
t/proc-01.hcl
View File

@ -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

6
t/retvar-01.hcl
View File

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

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 := 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)

10
t/var-01.hcl
View File

@ -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)
}
}

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);
y := (+ a a);
z := (- x y);

6
t/var-5001.err
View File

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

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