fis-gtm/sr_port/f_order.c

/****************************************************************
 *								*
 *	Copyright 2001, 2012 Fidelity Information Services, Inc	*
 *								*
 *	This source code contains the intellectual property	*
 *	of its copyright holder(s), and is made available	*
 *	under a license.  If you do not know the terms of	*
 *	the license, please stop and do not read further.	*
 *								*
 ****************************************************************/

#include "mdef.h"

#include "compiler.h"
#include "opcode.h"
#include "indir_enum.h"
#include "toktyp.h"
#include "fnorder.h"
#include "mdq.h"
#include "mmemory.h"
#include "advancewindow.h"
#include "mvalconv.h"
#include "fullbool.h"

/* The following are static triples used to pass information between functions "f_order" and "set_opcode" */
STATICDEF triple	*gvo2_savtarg1;	/* Save gv_currkey after processing gvn1 in $ORDER(gvn1,expr) */
STATICDEF triple	*gvo2_savtarg2;	/* Save gv_currkey after processing gvn1 and expr in $ORDER(gvn1,expr) but before executing
					 * the runtime function for $ORDER (OC_GVO2) */
STATICDEF triple	*gvo2_pre_srchindx_triple;	/* the end of the triple chain before OC_SRCHINDX got inserted */

error_def(ERR_ORDER2);
error_def(ERR_VAREXPECTED);

LITDEF	opctype order_opc[last_obj][last_dir] =
{
	/* forward	backward	undecided */
	{ OC_GVORDER,	OC_ZPREVIOUS,	OC_GVO2		},	/* global */
	{ OC_FNLVNAME,	OC_FNLVPRVNAME, OC_FNLVNAMEO2	},	/* local_name */
	{ OC_FNORDER,	OC_FNZPREVIOUS, OC_FNO2		},	/* local_sub */
	{ OC_INDFUN,	OC_INDFUN,	OC_INDO2	}	/* indir */
};

STATICFNDEF boolean_t set_opcode(triple *r, oprtype *result, oprtype *result_ptr, oprtype *second_opr, enum order_obj object)
{
	enum order_dir	direction;
	int4		dummy_intval;
	triple		*gvo2_post_srchindx_triple, *oldchain, *s, *t1, *t2, *tp, tmpchain, *tmptriple, *x;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	if (TK_COMMA == TREF(window_token))
	{
		advancewindow();
		if (local_sub == object)
			gvo2_post_srchindx_triple = (TREF(curtchain))->exorder.bl;
		if (global == object)
		{	/* Prepare for OC_GVSAVTARG/OC_GVRECTARG processing in case second argument has global references.
			 * If the first argument to $ORDER is a global variable and the second argument is a literal,
			 *	then the opcodes generated are (in that order)
			 *
			 *	OC_GVNAME, EXPR, OC_GVO2
			 *
			 * But if the first argument is a global variable and the second argument is an expression that is
			 *	not a literal, then the opcodes generated are (in that order)
			 *
			 *	OC_GVNAME, OC_SAVTARG1, EXPR, OC_SAVTARG2, OC_RECTARG1, OC_GVO2, OC_RECTARG2
			 *
			 * Note that OC_SAVTARG1 and OC_SAVTARG2 are the same opcode OC_SAVTARG but are placeholder indicators.
			 * Similarly OC_RECTARG1 and OC_RECTARG2.
			 *
			 * This opcode order ensures that OC_GVO2 is presented the right gv_currkey on entry into function
			 * "op_gvo2" as well as ensure that after the $ORDER returns, the naked indicator is set correctly.
			 */
			dqinit(&tmpchain, exorder);
			oldchain = setcurtchain(&tmpchain);
		}
		if (EXPR_FAIL == expr(result_ptr, MUMPS_EXPR))
		{
			if (global == object)
				setcurtchain(oldchain);
			return FALSE;
		}
		assert(TRIP_REF == result_ptr->oprclass);
		s = result_ptr->oprval.tref;
		if (OC_LIT == s->opcode)
		{
			if (MV_IS_TRUEINT(&s->operand[0].oprval.mlit->v, &dummy_intval)
					&& ((MV_BIAS == s->operand[0].oprval.mlit->v.m[1])
						||  (-MV_BIAS == s->operand[0].oprval.mlit->v.m[1])))
				direction = (MV_BIAS == s->operand[0].oprval.mlit->v.m[1]) ? forward : backward;
			else
			{
				if (global == object)
					setcurtchain(oldchain);
				stx_error(ERR_ORDER2);
				return FALSE;
			}
			if (global == object)
			{	/* No need for OC_GVSAVTARG/OC_GVRECTARG processing as expr is a constant (no global references) */
				setcurtchain(oldchain);
				tmptriple = (TREF(curtchain))->exorder.bl;
				dqadd(tmptriple, &tmpchain, exorder);
			}
		} else
		{
			direction = undecided;
			if (global == object)
			{	/* Need to do OC_GVSAVTARG/OC_GVRECTARG processing as expr could contain global references */
				assert(OC_GVO2 == order_opc[object][direction]);
				setcurtchain(oldchain);
				/* Note down the value of gv_currkey at this point */
				newtriple(OC_GVSAVTARG);
				/* Add second argument triples */
				gvo2_savtarg1 = (TREF(curtchain))->exorder.bl;
				tmptriple = (TREF(curtchain))->exorder.bl;
				dqadd(tmptriple, &tmpchain, exorder);
				/* Note down the value of gv_currkey at this point */
				newtriple(OC_GVSAVTARG);
				gvo2_savtarg2 = (TREF(curtchain))->exorder.bl;
			}
		}
	} else
		direction = forward;
	switch (object)
	{
	case global:
		if (direction == undecided)
			*second_opr = *result;
		break;
	case local_name:
		if (direction == undecided)
			*second_opr = *result;
		else if (direction == forward)
		{	/* The op_fnlvname rtn needs an extra parm - insert it now */
			assert(OC_FNLVNAME == order_opc[object][direction]);
			*second_opr = put_ilit(0);	/* Flag not to return aliases with no value */
		}
		break;
	case local_sub:
		if (direction == undecided)
		{	/* This is $ORDER(subscripted-local-variable, expr). The normal order of evaluation would be
			 *
			 * 1) Evaluate subscripts of local variable
			 * 2) Do OC_SRCHINDX
			 * 3) Evaluate expr
			 * 4) Do OC_FNORDER
			 *
			 * But it is possible that the subscripted local-variable is defined only by an extrinsic function
			 * that is part of "expr". In that case, we should NOT do the OC_SRCHINDX before "expr" gets
			 * evaluated (as otherwise OC_SRCHINDX will not return the right lv_val structure). That is, the
			 * order of evaluation should be
			 *
			 * 1) Evaluate subscripts of local variable
			 * 2) Evaluate expr
			 * 3) Do OC_SRCHINDX
			 * 4) Do OC_FNORDER
			 *
			 * The triples need to be reordered accordingly to implement the above evaluation order.
			 * This reordering of triples is implemented below by recording the end of the triple chain
			 * just BEFORE (variable "gvo2_pre_srchindx_triple") and just AFTER (variable
			 * "gvo2_post_srchindx_triple") parsing the subscripted-local-variable first argument to
			 * $ORDER. This is done partly in the function "f_order" and partly in "set_opcode". Once these
			 * are recorded, the second argument "expr" is parsed and the triples generated. After this, we
			 * start from gvo2_post_srchindx_triple and go back the triple chain until we find the OC_SRCHINDX
			 * opcode or gvo2_pre_srchindx_triple whichever is earlier (e.g. for unsubscripted names
			 * OC_SRCHINDX triple is not generated). This portion of the triple chain (that does the
			 * OC_SRCHINDX computation) is deleted and added at the end of the current triple chain. This
			 * accomplishes the desired evaluation reordering. Note that the value of the naked indicator is
			 * not affected by this reordering (since OC_SRCHINDX does not do global references).
			 */
			for (tmptriple = gvo2_post_srchindx_triple; (OC_SRCHINDX != tmptriple->opcode);
			      tmptriple = tmptriple->exorder.bl)
			{
				if (tmptriple == gvo2_pre_srchindx_triple)
					break;
			}
			if (OC_SRCHINDX == tmptriple->opcode)
			{
				t1 = tmptriple->exorder.bl;
				t2 = gvo2_post_srchindx_triple->exorder.fl;
				dqdelchain(t1,t2,exorder);
				dqinit(&tmpchain, exorder);
				tmpchain.exorder.fl = tmptriple;
				tmpchain.exorder.bl = gvo2_post_srchindx_triple;
				gvo2_post_srchindx_triple->exorder.fl = &tmpchain;
				tmptriple->exorder.bl = &tmpchain;
				tmptriple = (TREF(curtchain))->exorder.bl;
				dqadd(tmptriple, &tmpchain, exorder);
			}
			s = newtriple(OC_PARAMETER);
			s->operand[0] = *second_opr;
			s->operand[1] = *result;
			*second_opr = put_tref(s);
		}
		break;
	case indir:
		if (direction == forward)
			*second_opr = put_ilit((mint)indir_fnorder1);
		else
			if (direction == backward)
				*second_opr = put_ilit((mint)indir_fnzprevious);
			else
				*second_opr = *result;
		break;
	default:
		assert(FALSE);
	}
	r->opcode = order_opc[object][direction];
	return TRUE;
}

int f_order(oprtype *a, opctype op)
{
	enum order_obj	object;
	oprtype		result, *result_ptr, *second_opr;
	triple		*oldchain, *r, tmpchain, *triptr;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	result_ptr = (oprtype *)mcalloc(SIZEOF(oprtype));
	result = put_indr(result_ptr);
	r = maketriple(OC_NOOP);	/* We'll fill in the opcode later, when we figure out what it is */
	switch (TREF(window_token))
	{
	case TK_IDENT:
		if (TK_LPAREN == TREF(director_token))
		{	/* See comment in "set_opcode" for why we maintain "gvo2_pre_srchindx_triple" here */
			gvo2_pre_srchindx_triple = (TREF(curtchain))->exorder.bl;
			if (!lvn(&r->operand[0], OC_SRCHINDX, r))
				return FALSE;
			object = local_sub;
		} else
		{
			r->operand[0] = put_str((TREF(window_ident)).addr, (TREF(window_ident)).len);
			advancewindow();
			object = local_name;
		}
			second_opr = &r->operand[1];
		break;
	case TK_CIRCUMFLEX:
		if (!gvn())
			return FALSE;
		object = global;
		second_opr = &r->operand[0];
		break;
	case TK_ATSIGN:
		TREF(saw_side_effect) = TREF(shift_side_effects);
		if (TREF(shift_side_effects) && (GTM_BOOL == TREF(gtm_fullbool)))
		{
			dqinit(&tmpchain, exorder);
			oldchain = setcurtchain(&tmpchain);
			if (!indirection(&r->operand[0]))
			{
				setcurtchain(oldchain);
				return FALSE;
			}
			if (!set_opcode(r, &result, result_ptr, &r->operand[1], indir))
				return FALSE;
			ins_triple(r);
			newtriple(OC_GVSAVTARG);
			setcurtchain(oldchain);
			dqadd(TREF(expr_start), &tmpchain, exorder);
			TREF(expr_start) = tmpchain.exorder.bl;
			triptr = newtriple(OC_GVRECTARG);
			triptr->operand[0] = put_tref(TREF(expr_start));
			*a = put_tref(r);
			return TRUE;
		}
		if (!indirection(&r->operand[0]))
			return FALSE;
		object = indir;
		second_opr = &r->operand[1];
		break;
	default:
		stx_error(ERR_VAREXPECTED);
		return FALSE;
	}
	if (set_opcode(r, &result, result_ptr, second_opr, object))
	{	/* Restore gv_currkey of the first argument (in case the second expression contained a global reference).
		 * This will ensure op_gvo2 has gv_currkey set properly on entry */
		if (OC_GVO2 == r->opcode)
		{
			triptr = newtriple(OC_GVRECTARG);
			triptr->operand[0] = put_tref(gvo2_savtarg1);
			ins_triple(r);
			/* Restore gv_currkey to what it was after evaluating the second argument (to preserved naked indicator) */
			triptr = newtriple(OC_GVRECTARG);
			triptr->operand[0] = put_tref(gvo2_savtarg2);
		} else
			ins_triple(r);
		*a = put_tref(r);
		return TRUE;
	}
	return FALSE;
}