proper return variables handling in message sends

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 compile_cons_xlist_expression(hcl, oprnd, cf->u.obj_r.nrets);
-		return -1;
 	}
-
+	else if (HCL_CNODE_IS_CONS_CONCODED(oprnd, HCL_CONCODE_MLIST))
-	return compile_cons_xlist_expression(hcl, oprnd, cf->u.obj_r.nrets);
+	{
+		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)

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;
+				FETCH_PARAM_CODE_TO (hcl, b1); /* nargs */
-#endif
+				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?? */

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

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