diff --git a/lib/comp.c b/lib/comp.c index a34e13d..eeea555 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -399,7 +399,7 @@ static int emit_single_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1 goto write_long; } - hcl_seterrnum (hcl, HCL_EINVAL); + hcl_seterrbfmt (hcl, HCL_EINVAL, "unhandled single-parameter instruction %u", (unsigned int)cmd); return -1; write_short: @@ -409,7 +409,7 @@ write_short: write_long: if (param_1 > MAX_CODE_PARAM) { - hcl_seterrnum (hcl, HCL_ERANGE); + hcl_seterrbfmt (hcl, HCL_ERANGE, "parameter too large to single-parameter instruction %u", (unsigned int)cmd); return -1; } #if (HCL_CODE_LONG_PARAM_SIZE == 2) @@ -425,7 +425,7 @@ write_long: write_long2: if (param_1 > MAX_CODE_PARAM2) { - hcl_seterrnum (hcl, HCL_ERANGE); + hcl_seterrbfmt (hcl, HCL_ERANGE, "parameter too large to single-parameter instruction %u", (unsigned int)cmd); return -1; } #if (HCL_CODE_LONG_PARAM_SIZE == 2) @@ -476,11 +476,12 @@ static int emit_double_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1 */ case HCL_CODE_MAKE_BLOCK: case HCL_CODE_MAKE_FUNCTION: + case HCL_CODE_CALL_R: bc = cmd; goto write_long; } - hcl_seterrnum (hcl, HCL_EINVAL); + hcl_seterrbfmt (hcl, HCL_EINVAL, "unhandled double-parameter instruction %u", (unsigned int)cmd); return -1; write_short: @@ -491,7 +492,7 @@ write_short: write_long: if (param_1 > MAX_CODE_PARAM || param_2 > MAX_CODE_PARAM) { - hcl_seterrnum (hcl, HCL_ERANGE); + hcl_seterrbfmt (hcl, HCL_ERANGE, "parameter too large to double-parameter instruction %u", (unsigned int)cmd); return -1; } #if (HCL_CODE_LONG_PARAM_SIZE == 2) @@ -954,6 +955,7 @@ static HCL_INLINE hcl_cframe_t* find_cframe_from_top (hcl_t* hcl, int opcode) enum { COP_COMPILE_OBJECT, + COP_COMPILE_OBJECT_R, COP_COMPILE_ARGUMENT_LIST, COP_COMPILE_OBJECT_LIST, @@ -2035,6 +2037,104 @@ static int compile_set (hcl_t* hcl, hcl_cnode_t* src) cf->u.set.var_type = VAR_INDEXED; cf->u.set.index = index; } + cf->u.set.pop = 0; + + return 0; +} + +static int compile_set_r (hcl_t* hcl, hcl_cnode_t* src) +{ + hcl_cframe_t* cf; + hcl_cnode_t* cmd, * obj, * var, * val, * var_start; + hcl_oow_t index, nvars, i; + + HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src)); + HCL_ASSERT (hcl, HCL_CNODE_IS_SYMBOL_SYNCODED(HCL_CNODE_CONS_CAR(src), HCL_SYNCODE_SET_R)); + + cmd = HCL_CNODE_CONS_CAR(src); + obj = HCL_CNODE_CONS_CDR(src); + + if (!obj) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_CNODE_GET_LOC(src), HCL_NULL, "no variable 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; + } + + nvars = 0; + var_start = obj; + do + { + var = HCL_CNODE_CONS_CAR(obj); + if (!HCL_CNODE_IS_SYMBOL(var)) + { + if (nvars > 0) break; + hcl_setsynerrbfmt (hcl, HCL_SYNERR_VARNAME, HCL_CNODE_GET_LOC(var), HCL_CNODE_GET_TOK(var), "variable name not a symbol in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); + return -1; + } + + if (HCL_CNODE_SYMBOL_SYNCODE(var)/* || HCL_OBJ_GET_FLAGS_KERNEL(var) >= 2*/) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNEDVARNAME, HCL_CNODE_GET_LOC(var), HCL_CNODE_GET_TOK(var), "special symbol not to be used as a variable name in %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); + return -1; + } + + nvars++; + obj = HCL_CNODE_CONS_CDR(obj); + } + while (obj); + + + if (!obj) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_CNODE_GET_LOC(src), HCL_NULL, "no value specified 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; + } + + val = HCL_CNODE_CONS_CAR(obj); + + obj = HCL_CNODE_CONS_CDR(obj); + if (obj) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_CNODE_GET_LOC(obj), HCL_CNODE_GET_TOK(obj), "too many arguments to %.*js", HCL_CNODE_GET_TOKLEN(cmd), HCL_CNODE_GET_TOKPTR(cmd)); + return -1; + } + + SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_R, val); + cf = GET_TOP_CFRAME(hcl); + cf->u.obj_r.nrets = nvars; + + for (i = 0, obj = var_start; i < nvars; i++, obj = HCL_CNODE_CONS_CDR(obj)) + { + var = HCL_CNODE_CONS_CAR(obj); + if (find_temporary_variable_backward(hcl, HCL_CNODE_GET_TOK(var), &index) <= -1) + { + PUSH_SUBCFRAME (hcl, COP_EMIT_SET, var); /* set_r doesn't evaluate the variable name */ + cf = GET_SUBCFRAME(hcl); + cf->u.set.var_type = VAR_NAMED; + } + else + { + /* the check in compile_lambda() must ensure this condition */ + HCL_ASSERT (hcl, index <= HCL_SMOOI_MAX); + + PUSH_SUBCFRAME (hcl, COP_EMIT_SET, cmd); + cf = GET_SUBCFRAME(hcl); + cf->u.set.var_type = VAR_INDEXED; + cf->u.set.index = index; + } + + cf->u.set.pop = (i > 0); /* STORE_INTO or POP_INTO */ + } return 0; } @@ -2429,7 +2529,7 @@ static int compile_cons_qlist_expression (hcl_t* hcl, hcl_cnode_t* obj) return 0; } -static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj) +static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj, int nrets) { hcl_cnode_t* car; int syncode; /* syntax code of the first element */ @@ -2447,6 +2547,12 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj) car = HCL_CNODE_CONS_CAR(obj); if (HCL_CNODE_IS_SYMBOL(car) && (syncode = HCL_CNODE_SYMBOL_SYNCODE(car))) { + if (nrets > 0) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_CALLABLE, HCL_CNODE_GET_LOC(car), HCL_CNODE_GET_TOK(car), "not a function with return-variables"); + return -1; + } + switch (syncode) { case HCL_SYNCODE_AND: @@ -2502,6 +2608,11 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj) if (compile_set(hcl, obj) <= -1) return -1; break; + case HCL_SYNCODE_SET_R: + /* (set-r a b (func 10 20)) */ + if (compile_set_r(hcl, obj) <= -1) return -1; + break; + case HCL_SYNCODE_RETURN: /* (return 10) * (return (+ 10 20)) */ @@ -2611,6 +2722,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj) cf = GET_CFRAME(hcl, oldtop); HCL_ASSERT (hcl, cf->opcode == COP_EMIT_CALL); cf->u.call.index = nargs; + cf->u.call.nrets = nrets; } else { @@ -2907,7 +3019,7 @@ redo: switch (HCL_CNODE_CONS_CONCODE(oprnd)) { case HCL_CONCODE_XLIST: - if (compile_cons_xlist_expression(hcl, oprnd) <= -1) return -1; + if (compile_cons_xlist_expression(hcl, oprnd, 0) <= -1) return -1; break; case HCL_CONCODE_ARRAY: @@ -2994,6 +3106,8 @@ redo: return -1; } + /* the control reaches here in case a compile_xxxx() functionse.g. compile_cons_xlist_expression) is called. + * such a function removes the top cframe. so POP_CFRAME() needs not be called here */ return 0; literal: @@ -3004,6 +3118,27 @@ done: return 0; } + +static int compile_object_r (hcl_t* hcl) +{ + hcl_cframe_t* cf; + hcl_cnode_t* oprnd; + hcl_oop_t lit; + + cf = GET_TOP_CFRAME(hcl); + HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_OBJECT_R); + HCL_ASSERT (hcl, cf->operand != HCL_NULL); + + oprnd = cf->operand; + if (!HCL_CNODE_IS_CONS_CONCODED(oprnd, HCL_CONCODE_XLIST)) + { + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNED, HCL_CNODE_GET_LOC(oprnd), HCL_NULL, "non-function call disallowed"); + return -1; + } + + return compile_cons_xlist_expression(hcl, oprnd, cf->u.obj_r.nrets); +} + static int compile_object_list (hcl_t* hcl) { hcl_cframe_t* cf; @@ -3113,7 +3248,10 @@ static int compile_object_list (hcl_t* hcl) cop == COP_COMPILE_TRY_OBJECT_LIST_TAIL) { /* emit POP_STACKTOP before evaluating the second objects - * and onwards. this goes above COP_COMPILE_OBJECT */ + * and onwards. this goes above COP_COMPILE_OBJECT. + + /* TODO: if the previous operators is known to divert execution flow, it may skip this. + * for instance, some 'RETURN" or 'JUMP' operators */ PUSH_CFRAME (hcl, COP_EMIT_POP_STACKTOP, oprnd); } } @@ -3507,7 +3645,14 @@ static HCL_INLINE int emit_call (hcl_t* hcl) HCL_ASSERT (hcl, cf->opcode == COP_EMIT_CALL); HCL_ASSERT (hcl, cf->operand != HCL_NULL); - n = emit_single_param_instruction(hcl, HCL_CODE_CALL_0, cf->u.call.index, HCL_CNODE_GET_LOC(cf->operand)); + if (cf->u.call.nrets > 0) + { + n = emit_double_param_instruction(hcl, HCL_CODE_CALL_R, cf->u.call.index, cf->u.call.nrets, HCL_CNODE_GET_LOC(cf->operand)); + } + else + { + n = emit_single_param_instruction(hcl, HCL_CODE_CALL_0, cf->u.call.index, HCL_CNODE_GET_LOC(cf->operand)); + } POP_CFRAME (hcl); return n; @@ -3736,6 +3881,7 @@ static HCL_INLINE int post_lambda (hcl_t* hcl) cf->u.set.var_type = VAR_INDEXED; cf->u.set.index = index; } + cf->u.set.pop = 0; } else { @@ -3802,13 +3948,16 @@ static HCL_INLINE int emit_set (hcl_t* hcl) } if (add_literal(hcl, cons, &index) <= -1 || - emit_single_param_instruction(hcl, HCL_CODE_STORE_INTO_OBJECT_0, index, HCL_CNODE_GET_LOC(cf->operand)) <= -1) return -1; + emit_single_param_instruction(hcl, (cf->u.set.pop? HCL_CODE_POP_INTO_OBJECT_0: HCL_CODE_STORE_INTO_OBJECT_0), index, HCL_CNODE_GET_LOC(cf->operand)) <= -1) return -1; } else { HCL_ASSERT (hcl, cf->u.set.var_type == VAR_INDEXED); HCL_ASSERT (hcl, cf->operand != HCL_NULL); - if (emit_indexed_variable_access(hcl, cf->u.set.index, HCL_CODE_STORE_INTO_CTXTEMPVAR_0, HCL_CODE_STORE_INTO_TEMPVAR_0, HCL_CNODE_GET_LOC(cf->operand)) <= -1) return -1; + if (emit_indexed_variable_access(hcl, cf->u.set.index, + (cf->u.set.pop? HCL_CODE_POP_INTO_CTXTEMPVAR_0: HCL_CODE_STORE_INTO_CTXTEMPVAR_0), + (cf->u.set.pop? HCL_CODE_POP_INTO_TEMPVAR_0: HCL_CODE_STORE_INTO_TEMPVAR_0), + HCL_CNODE_GET_LOC(cf->operand)) <= -1) return -1; } POP_CFRAME (hcl); @@ -3915,6 +4064,10 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags) if (compile_object(hcl) <= -1) goto oops; break; + case COP_COMPILE_OBJECT_R: + if (compile_object_r(hcl) <= -1) goto oops; + break; + case COP_COMPILE_ARGUMENT_LIST: case COP_COMPILE_OBJECT_LIST: case COP_COMPILE_OBJECT_LIST_TAIL: diff --git a/lib/exec.c b/lib/exec.c index 7f7540e..9a63689 100644 --- a/lib/exec.c +++ b/lib/exec.c @@ -3118,28 +3118,34 @@ static int execute (hcl_t* hcl) { hcl_oop_context_t ctx; hcl_oow_t i; - hcl_ooi_t tmpr_mask, fixed_nargs; + hcl_ooi_t tmpr_mask, fixed_nargs, req_nrets; LOG_INST_0 (hcl, "push_return_r"); HCL_ASSERT(hcl, HCL_IS_CONTEXT(hcl, hcl->active_context)); ctx = hcl->active_context; + tmpr_mask = HCL_OOP_TO_SMOOI(ctx->tmpr_mask); fixed_nargs = GET_BLKTMPR_MASK_NARGS(tmpr_mask); - i = HCL_OOP_TO_SMOOI(ctx->req_nrets); + req_nrets = HCL_OOP_TO_SMOOI(ctx->req_nrets); + + if (req_nrets <= 0) + { + /* if a function with return variables is called in the single-return value call style, + * req_nrets becomes 0. but this instruction has to push one value in such a case */ + req_nrets = 1; + } /* return variables are placed after the fixed arguments */ - while (i > 0) + for (i = 0; i < req_nrets; i++) { - --i; HCL_STACK_PUSH (hcl, ctx->slot[fixed_nargs + i]); } - /* same as HCL_CODE_RETURN_FROM_BLOCK */ - - hcl->last_retv = HCL_STACK_GETTOP(hcl); /* get the stack top */ + /* similar to HCL_CODE_RETURN_FROM_BLOCK */ + hcl->last_retv = ctx->slot[fixed_nargs]; /* remember the first pushed one as the last return value. currently no good way to hcl_execute() recognize multiple return values. */ do_return_from_block (hcl); break; @@ -3193,7 +3199,7 @@ static int execute (hcl_t* hcl) break; case HCL_BRAND_BLOCK: - if (activate_block(hcl, b1, 1) <= -1) goto call_failed; + if (activate_block(hcl, b1, 0) <= -1) goto call_failed; break; case HCL_BRAND_PRIM: diff --git a/lib/gc.c b/lib/gc.c index b1e0de6..546f540 100644 --- a/lib/gc.c +++ b/lib/gc.c @@ -54,6 +54,7 @@ static struct { 16, { 'r','e','t','u','r','n','-','f','r','o','m','-','h','o','m','e'}, HCL_SYNCODE_RETURN_FROM_HOME, HCL_OFFSETOF(hcl_t,_return_from_home) }, { 3, { 's','e','t' }, HCL_SYNCODE_SET, HCL_OFFSETOF(hcl_t,_set) }, + { 5, { 's','e','t','-','r' }, HCL_SYNCODE_SET_R, HCL_OFFSETOF(hcl_t,_set_r) }, { 5, { 't','h','r','o','w' }, HCL_SYNCODE_THROW, HCL_OFFSETOF(hcl_t,_throw) }, { 3, { 't','r','y' }, HCL_SYNCODE_TRY, HCL_OFFSETOF(hcl_t,_try) }, { 5, { 'u','n','t','i','l' }, HCL_SYNCODE_UNTIL, HCL_OFFSETOF(hcl_t,_until) }, diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index 8b29505..3873689 100644 --- a/lib/hcl-prv.h +++ b/lib/hcl-prv.h @@ -283,15 +283,23 @@ struct hcl_cframe_t union { + /* COP_COMPILE_OBJECT_R */ + struct + { + hcl_ooi_t nrets; + } obj_r; + /* COP_EMIT_CALL */ struct { hcl_ooi_t index; + hcl_ooi_t nrets; } call; /* COP_EMIT_SET */ struct { + int pop; int var_type; hcl_ooi_t index; } set; diff --git a/lib/hcl.h b/lib/hcl.h index 5436658..d738625 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -1441,6 +1441,7 @@ struct hcl_t hcl_oop_t _return; /* symbol */ hcl_oop_t _return_from_home; /* symbol */ hcl_oop_t _set; /* symbol */ + hcl_oop_t _set_r; /* symbol */ hcl_oop_t _throw; /* symbol */ hcl_oop_t _try; /* symbol */ hcl_oop_t _until; /* symbol */ @@ -1717,6 +1718,7 @@ enum hcl_syncode_t HCL_SYNCODE_RETURN, HCL_SYNCODE_RETURN_FROM_HOME, HCL_SYNCODE_SET, + HCL_SYNCODE_SET_R, HCL_SYNCODE_THROW, HCL_SYNCODE_TRY, HCL_SYNCODE_UNTIL,