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

fixed wrong instructions generated for set-r and return variables.

Browse Source 
class variables access fixed to use hcl->active_context->home->owner instead of hcl->active_context->owner
This commit is contained in:
hyung-hwan 2022-02-19 16:57:06 +00:00
parent 026ece9aea
commit e482ce620f
3 changed files with 52 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
lib/comp.c
View File

@ -2756,7 +2756,7 @@ static int compile_set_r (hcl_t* hcl, hcl_cnode_t* src)
{ {
hcl_cframe_t* cf; hcl_cframe_t* cf;
hcl_cnode_t* cmd, * obj, * var, * val, * var_start; hcl_cnode_t* cmd, * obj, * var, * val, * var_start;
hcl_oow_t index, nvars, i; hcl_oow_t nvars, i;
hcl_var_info_t vi; hcl_var_info_t vi;
HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src)); HCL_ASSERT (hcl, HCL_CNODE_IS_CONS(src));
@ -2822,7 +2822,7 @@ static int compile_set_r (hcl_t* hcl, hcl_cnode_t* src)
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_R, val); /* special for set_r */ SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_R, val); /* special for set_r */
cf = GET_TOP_CFRAME(hcl); cf = GET_TOP_CFRAME(hcl);
cf->u.obj_r.nrets = nvars; cf->u.obj_r.nrets = nvars; /* number of return variables to get assigned */
for (i = 0, obj = var_start; i < nvars; i++, obj = HCL_CNODE_CONS_CDR(obj)) for (i = 0, obj = var_start; i < nvars; i++, obj = HCL_CNODE_CONS_CDR(obj))
{ {
@ -2841,13 +2841,30 @@ static int compile_set_r (hcl_t* hcl, hcl_cnode_t* src)
} }
else else
{ {
/* the check in compile_lambda() must ensure this condition */
HCL_ASSERT (hcl, index <= HCL_SMOOI_MAX);
PUSH_SUBCFRAME (hcl, COP_EMIT_SET, cmd); PUSH_SUBCFRAME (hcl, COP_EMIT_SET, cmd);
cf = GET_SUBCFRAME(hcl); cf = GET_SUBCFRAME(hcl);
cf->u.set.vi = vi; cf->u.set.vi = vi;
} }
cf->u.set.mode = (i > 0)? VAR_ACCESS_STORE: VAR_ACCESS_POP; /* STORE_INTO or POP_INTO */
/*
* (defun f(x y ::: aa bb cc) ....)
* (set_r a b c (f 1 2))
*
* the call to f
* call 2 3 ; 2 arguments, 3 return variables (CALL_R)
* ; 3 to be emitted from cf->u.obj_r.nrets
* ; this gets remembered in req_nrvars of the created context.
*
* the return from f must push 3 values.
* push_return_r ; as remembered in the ctx->req_nrvars
*
* emit store_into_xxx instruction for the first return variable assignment.
* emit pop_into_xxx instructions for the rest.
* pop_into c
* pop_into b
* store_into a
*/
cf->u.set.mode = (i <= 0)? VAR_ACCESS_STORE: VAR_ACCESS_POP; /* STORE_INTO or POP_INTO */
} }
return 0; return 0;

7
lib/exec.c
View File

@ -3430,6 +3430,7 @@ static int execute (hcl_t* hcl)
/* return variables are placed after the fixed arguments */ /* return variables are placed after the fixed arguments */
for (i = 0; i < req_nrets; i++) 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]); HCL_STACK_PUSH (hcl, ctx->slot[fixed_nargs + i]);
} }
@ -3940,7 +3941,7 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1)
hcl_oop_t t; hcl_oop_t t;
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "push_cvar_m %zu", b1); LOG_INST_1 (hcl, "push_cvar_m %zu", b1);
t = hcl->active_context->owner; t = hcl->active_context->home->owner;
if (HCL_UNLIKELY(!HCL_IS_CLASS(hcl, t))) if (HCL_UNLIKELY(!HCL_IS_CLASS(hcl, t)))
{ {
/* this is an internal error or the bytecodes are compromised */ /* this is an internal error or the bytecodes are compromised */
@ -3956,7 +3957,7 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1)
hcl_oop_t t; hcl_oop_t t;
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "store_into_cvar_m %zu", b1); LOG_INST_1 (hcl, "store_into_cvar_m %zu", b1);
t = hcl->active_context->owner; t = hcl->active_context->home->owner;
if (HCL_UNLIKELY(!HCL_IS_CLASS(hcl, t))) if (HCL_UNLIKELY(!HCL_IS_CLASS(hcl, t)))
{ {
/* this is an internal error or the bytecodes are compromised */ /* this is an internal error or the bytecodes are compromised */
@ -3972,7 +3973,7 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1)
hcl_oop_t t; hcl_oop_t t;
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "pop_into_cvar_m %zu", b1); LOG_INST_1 (hcl, "pop_into_cvar_m %zu", b1);
t = hcl->active_context->owner; t = hcl->active_context->home->owner;
if (HCL_UNLIKELY(!HCL_IS_CLASS(hcl, t))) if (HCL_UNLIKELY(!HCL_IS_CLASS(hcl, t)))
{ {
/* this is an internal error or the bytecodes are compromised */ /* this is an internal error or the bytecodes are compromised */

26
t/retvar-01.hcl Normal file
View File

@ -0,0 +1,26 @@
((lambda ()
; test return variables
| v1 v2 v3 i |
(set i 100)
(defun ff(a b ::: x y z)
(set x (+ a b i))
(set y (+ x x))
(set z (+ 999 i))
(set i (* i 10))
)
(set-r v1 v2 v3 (ff 10 20))
(if (/= v1 130) (printf "ERROR: v1 must be 130\n"))
(if (/= v2 260) (printf "ERROR: v2 must be 260\n"))
(if (/= v3 1099) (printf "ERROR: v3 must be 1099\n"))
(printf "OK v1=%d v2=%d v3=%d\n" v1 v2 v3)
(set-r v1 v2 (ff 1 2)) ; using 2 return variables only. not assigning to v3
(if (/= v1 1003) (printf "ERROR: v1 must be 1003\n"))
(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)
))