From 6d409c809f1e6a76def126823908093cc17105bd Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Mon, 21 Feb 2022 16:07:55 +0000 Subject: [PATCH] proper return variables handling in message sends --- lib/comp.c | 16 ++++++++++------ lib/exec.c | 20 ++++++++++++-------- lib/hcl-prv.h | 4 ++-- t/retvar-01.hcl | 33 ++++++++++++++++++++++++++++++++- 4 files changed, 56 insertions(+), 17 deletions(-) diff --git a/lib/comp.c b/lib/comp.c index 681f1db..81dc11b 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -646,6 +646,7 @@ 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: + case HCL_CODE_SEND_R: bc = cmd; goto write_long; } @@ -4030,7 +4031,6 @@ done: return 0; } - static int compile_object_r (hcl_t* hcl) { hcl_cframe_t* cf; @@ -4041,13 +4041,17 @@ static int compile_object_r (hcl_t* hcl) HCL_ASSERT (hcl, cf->operand != HCL_NULL); oprnd = cf->operand; - if (!HCL_CNODE_IS_CONS_CONCODED(oprnd, HCL_CONCODE_XLIST)) + 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); } - - return compile_cons_xlist_expression(hcl, oprnd, cf->u.obj_r.nrets); + else if (HCL_CNODE_IS_CONS_CONCODED(oprnd, HCL_CONCODE_MLIST)) + { + return compile_cons_mlist_expression(hcl, oprnd, cf->u.obj_r.nrets); + } + + hcl_setsynerrbfmt (hcl, HCL_SYNERR_BANNED, HCL_CNODE_GET_LOC(oprnd), HCL_NULL, "non-function call/non-message send disallowed"); + return -1; } static int compile_object_list (hcl_t* hcl) diff --git a/lib/exec.c b/lib/exec.c index b302ab5..c523516 100644 --- a/lib/exec.c +++ b/lib/exec.c @@ -2226,7 +2226,7 @@ static hcl_oop_block_t find_imethod_noseterr (hcl_t* hcl, hcl_oop_class_t class_ return HCL_NULL; } -static HCL_INLINE int send_message (hcl_t* hcl, hcl_oop_t rcv, hcl_oop_t msg, int to_super, hcl_ooi_t nargs) +static HCL_INLINE int send_message (hcl_t* hcl, hcl_oop_t rcv, hcl_oop_t msg, int to_super, hcl_ooi_t nargs, hcl_ooi_t nrvars) { hcl_oop_block_t mth_blk; hcl_oop_context_t newctx; @@ -2257,7 +2257,7 @@ static HCL_INLINE int send_message (hcl_t* hcl, hcl_oop_t rcv, hcl_oop_t msg, in return -1; } - x = __activate_block(hcl, mth_blk, nargs, 0 /* TODO: not always 0, support nrvars */, 1, ivaroff, &newctx); + x = __activate_block(hcl, mth_blk, nargs, nrvars, 1 /* is_msgsend */, ivaroff, &newctx); if (HCL_UNLIKELY(x <= -1)) return -1; /* update the method owner field of the new context created */ @@ -3430,7 +3430,6 @@ static int execute (hcl_t* hcl) /* return variables are placed after the fixed arguments */ for (i = 0; i < req_nrets; i++) { -HCL_DEBUG1 (hcl, "PUSHING %O\n", ctx->slot[fixed_nargs + i]); HCL_STACK_PUSH (hcl, ctx->slot[fixed_nargs + i]); } @@ -3827,12 +3826,15 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1) } /* -------------------------------------------------------- */ -#if 0 case HCL_CODE_SEND_R: case HCL_CODE_SEND_TO_SUPER_R: - /* TODO ........ */ - break; -#endif + + FETCH_PARAM_CODE_TO (hcl, b1); /* nargs */ + FETCH_PARAM_CODE_TO (hcl, b2); /* nrvars */ + + LOG_INST_3 (hcl, "send%hs %zu %zu", (((bcode >> 2) & 1)? "_to_super": ""), b1, b2); + goto handle_send_2; + case HCL_CODE_SEND_X: case HCL_CODE_SEND_TO_SUPER_X: @@ -3851,9 +3853,11 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1) hcl_oop_t rcv, op; b1 = bcode & 0x3; /* low 2 bits */ + b2 = 0; handle_send: LOG_INST_2 (hcl, "send%hs %zu", (((bcode >> 2) & 1)? "_to_super": ""), b1); + handle_send_2: rcv = HCL_STACK_GETRCV(hcl, b1); op = HCL_STACK_GETOP(hcl, b1); if (!HCL_IS_SYMBOL(hcl, op)) @@ -3863,7 +3867,7 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1) } else if (HCL_IS_CLASS(hcl, rcv) || HCL_IS_INSTANCE(hcl, rcv)) { - if (send_message(hcl, rcv, op, ((bcode >> 2) & 1) /* to_super */, b1 /* nargs */) <= -1) + if (send_message(hcl, rcv, op, ((bcode >> 2) & 1) /* to_super */, b1 /* nargs */, b2 /* nrvars */) <= -1) { const hcl_ooch_t* msg = hcl_backuperrmsg (hcl); hcl_seterrbfmt (hcl, HCL_ECALL, "unable to send %O to %O - %js", op, rcv, msg); /* TODO: change to HCL_ESEND?? */ diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index 3c1a1a8..37339c9 100644 --- a/lib/hcl-prv.h +++ b/lib/hcl-prv.h @@ -949,13 +949,13 @@ enum hcl_bcode_t HCL_CODE_POP_INTO_DIC = 0xEF, /* 239 */ HCL_CODE_SEND_X = 0xF0, /* 240 ## */ - HCL_CODE_SEND_R = 0xF1, /* 241 ## ## */ + HCL_CODE_SEND_R = 0xF1, /* 241 ## ## - [NOTE] ((code >> 2) & 1) must be 0 */ HCL_CODE_MAKE_CONS = 0xF2, /* 242 */ HCL_CODE_POP_INTO_CONS = 0xF3, /* 243 */ HCL_CODE_SEND_TO_SUPER_X = 0xF4, /* 244 ## */ - HCL_CODE_SEND_TO_SUPER_R = 0xF5, /* 245 ## ## */ + HCL_CODE_SEND_TO_SUPER_R = 0xF5, /* 245 ## ## - [NOTE] ((code >> 2) & 1) must be 0 */ HCL_CODE_POP_INTO_CONS_END = 0xF6, /* 246 */ HCL_CODE_POP_INTO_CONS_CDR = 0xF7, /* 247 */ diff --git a/t/retvar-01.hcl b/t/retvar-01.hcl index 888fc9f..3f688f1 100644 --- a/t/retvar-01.hcl +++ b/t/retvar-01.hcl @@ -1,7 +1,7 @@ ((lambda () ; test return variables - | v1 v2 v3 i | + | v1 v2 v3 i a b c d | (set i 100) @@ -23,4 +23,35 @@ (if (/= v2 2006) (printf "ERROR: v2 must be 2006\n")) (if (/= v3 1099) (printf "ERROR: v3 must be 1099\n")) (printf "OK v1=%d v2=%d v3=%d\n" v1 v2 v3) + + + + + ; test return variables in message sends + (defclass B + ::: | X1 X2 | + + (set X1 999) + (set X2 888) + + (defun ::: get ( ::: x y) + (set x X1) + (set y X2) + ) + + (defun ::: get2 (inc ::: x y) + (set x (+ X1 inc)) + (set y (+ X2 inc)) + ) + ) + + (set-r a b (:B get)) + (set-r c d (:B get2 -100)) + + (if (/= a 999) (printf "ERROR: a must be 999\n")) + (if (/= b 888) (printf "ERROR: b must be 888\n")) + (if (/= c 899) (printf "ERROR: c must be 899\n")) + (if (/= d 788) (printf "ERROR: d must be 788\n")) + + (printf "OK: a=%d b=%d c=%d d=%d\n" a b c d) ))