示例#1
0
triple *maketriple(opctype op)
{
	triple *x;

	x = (triple *)mcalloc(SIZEOF(triple));
	x->opcode = op;
	x->src.line = source_line;
	x->src.column = source_column;
	dqinit(&(x->backptr), que);
	dqinit(&(x->jmplist), que);
	return x;
}
示例#2
0
int m_xecute(void)
{
	oprtype *cr, x;
	triple *obp, *oldchain, *ref0, *ref1, tmpchain, *triptr;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	dqinit(&tmpchain,exorder);
	oldchain = setcurtchain(&tmpchain);
	switch (expr(&x, MUMPS_STR))
	{
	case EXPR_FAIL:
		setcurtchain(oldchain);
		return FALSE;
	case EXPR_INDR:
		if (TK_COLON != TREF(window_token))
		{
			make_commarg(&x,indir_xecute);
			break;
		}
		/* caution: fall through */
	case EXPR_GOOD:
		ref0 = maketriple(OC_COMMARG);
		ref0->operand[0] = x;
		ref0->operand[1] = put_ilit(indir_linetail);
		ins_triple(ref0);
	}
	setcurtchain(oldchain);
	if (TK_COLON == TREF(window_token))
	{
		advancewindow();
		cr = (oprtype *)mcalloc(SIZEOF(oprtype));
		if (!bool_expr(FALSE, cr))
			return FALSE;
		if (TREF(expr_start) != TREF(expr_start_orig))
		{
			triptr = newtriple(OC_GVRECTARG);
			triptr->operand[0] = put_tref(TREF(expr_start));
		}
		obp = oldchain->exorder.bl;
		dqadd(obp,&tmpchain,exorder);		/* violates info hiding */
		if (TREF(expr_start) != TREF(expr_start_orig))
		{
			ref0 = newtriple(OC_JMP);
			ref1 = newtriple(OC_GVRECTARG);
			ref1->operand[0] = put_tref(TREF(expr_start));
			*cr = put_tjmp(ref1);
			tnxtarg(&ref0->operand[0]);
		} else
			tnxtarg(cr);
		return TRUE;
	}
	obp = oldchain->exorder.bl;
	dqadd(obp,&tmpchain,exorder);		/* violates info hiding */
	return TRUE;
}
示例#3
0
int f_data(oprtype *a, opctype op)
{
	triple *oldchain, *r, tmpchain, *triptr;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	assert(OC_FNDATA == op || OC_FNZDATA == op);
	r = maketriple(op);
	switch (TREF(window_token))
	{
	case TK_IDENT:
		if (!lvn(&(r->operand[0]), OC_SRCHINDX, 0))
			return FALSE;
		ins_triple(r);
		break;
	case TK_CIRCUMFLEX:
		if (!gvn())
			return FALSE;
		r->opcode = OC_GVDATA;
		ins_triple(r);
		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;
			}
			r->operand[1] = put_ilit((mint)(OC_FNDATA == op ? indir_fndata : indir_fnzdata));
			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));
		} else
		{
			if (!indirection(&(r->operand[0])))
				return FALSE;
			r->operand[1] = put_ilit((mint)(OC_FNDATA == op ? indir_fndata : indir_fnzdata));
			ins_triple(r);
		}
		r->opcode = OC_INDFUN;
		break;
	default:
		stx_error(ERR_VAREXPECTED);
		return FALSE;
	}
	*a = put_tref(r);
	return TRUE;
}
示例#4
0
void
ufs_init()
{
	static int done = 0;

	if (done)
		return;
	done = 1;
	ufs_ihashinit();
#ifdef QUOTA
	dqinit();
#endif
	return;
}
示例#5
0
int
ufs_init()
{
	static int first = 1;

	if (!first)
		return (0);
	first = 0;

#ifdef DIAGNOSTIC
	if ((sizeof(struct inode) - 1) & sizeof(struct inode))
		printf("ufs_init: bad size %d\n", sizeof(struct inode));
#endif
	ufs_ihashinit();
	dqinit();
	return (0);
}
示例#6
0
int m_goto(void)
{
	oprtype	*cr;
	triple	*obp, *oldchain, *ref0, *ref1, tmpchain, *triptr;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	dqinit(&tmpchain, exorder);
	oldchain = setcurtchain(&tmpchain);
	if (!entryref(OC_JMP, OC_EXTJMP, (mint)indir_goto, TRUE, FALSE, FALSE))
	{
		setcurtchain(oldchain);
		return FALSE;
	}
	setcurtchain(oldchain);
	if (TK_COLON == TREF(window_token))
	{
		advancewindow();
		cr = (oprtype *)mcalloc(SIZEOF(oprtype));
		if (!bool_expr(FALSE, cr))
			return FALSE;
		if ((TREF(expr_start) != TREF(expr_start_orig)) && (OC_NOOP != (TREF(expr_start))->opcode))
		{
			triptr = newtriple(OC_GVRECTARG);
			triptr->operand[0] = put_tref(TREF(expr_start));
		}
		obp = oldchain->exorder.bl;
		dqadd(obp, &tmpchain, exorder);   /*this is a violation of info hiding*/
		if ((TREF(expr_start) != TREF(expr_start_orig)) && (OC_NOOP != (TREF(expr_start))->opcode))
		{
			ref0 = newtriple(OC_JMP);
			ref1 = newtriple(OC_GVRECTARG);
			ref1->operand[0] = put_tref(TREF(expr_start));
			*cr = put_tjmp(ref1);
			tnxtarg(&ref0->operand[0]);
		} else
			tnxtarg(cr);
		return TRUE;
	}
	obp = oldchain->exorder.bl;
	dqadd(obp, &tmpchain, exorder);   /*this is a violation of info hiding*/
	return TRUE;
}
示例#7
0
文件: m_goto.c 项目: 5HT/mumps
int m_goto(void)
{
	triple tmpchain, *oldchain, *obp, *ref0, *ref1, *triptr;
	oprtype *cr;

	dqinit(&tmpchain, exorder);
	oldchain = setcurtchain(&tmpchain);
	if (!entryref(OC_JMP, OC_EXTJMP, (mint) indir_goto, TRUE, FALSE))
	{
		setcurtchain(oldchain);
		return FALSE;
	}
	setcurtchain(oldchain);
	if (window_token == TK_COLON)
	{
		advancewindow();
		cr = (oprtype *) mcalloc(sizeof(oprtype));
		if (!bool_expr((bool) FALSE, cr))
			return FALSE;
		if (expr_start != expr_start_orig)
		{
			triptr = newtriple(OC_GVRECTARG);
			triptr->operand[0] = put_tref(expr_start);
		}
		obp = oldchain->exorder.bl;
		dqadd(obp, &tmpchain, exorder);   /*this is a violation of info hiding*/
		if (expr_start != expr_start_orig)
		{
			ref0 = newtriple(OC_JMP);
			ref1 = newtriple(OC_GVRECTARG);
			ref1->operand[0] = put_tref(expr_start);
			*cr = put_tjmp(ref1);
			tnxtarg(&ref0->operand[0]);
		}
		else
			tnxtarg(cr);
		return TRUE;
	}
	obp = oldchain->exorder.bl;
	dqadd(obp, &tmpchain, exorder);   /*this is a violation of info hiding*/
	return TRUE;
}
示例#8
0
/*
 * Initialize UFS filesystems, done only once.
 */
void
ufs_init(void)
{
	if (ufs_initcount++ > 0)
		return;

	ufs_direct_cache = pool_cache_init(sizeof(struct direct), 0, 0, 0,
	    "ufsdir", NULL, IPL_NONE, NULL, NULL, NULL);

	ufs_ihashinit();
#ifdef QUOTA
	dqinit();
#endif
#ifdef UFS_DIRHASH
	ufsdirhash_init();
#endif
#ifdef UFS_EXTATTR
	ufs_extattr_init();
#endif
}
示例#9
0
文件: gvn.c 项目: h4ck3rm1k3/fis-gtm
int gvn(void)
{
	triple		*ref, *t1, *oldchain, tmpchain, *triptr, *s;
	oprtype		subscripts[MAX_GVSUBSCRIPTS], *sb1, *sb2;
	boolean_t	shifting, vbar, parse_status;
	opctype		ox;
	char		x;
	error_def(ERR_MAXNRSUBSCRIPTS);
	error_def(ERR_RPARENMISSING);
	error_def(ERR_GBLNAME);
	error_def(ERR_EXTGBLDEL);
	error_def(ERR_GVNAKEDEXTNM);
	error_def(ERR_EXPR);
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	assert(window_token == TK_CIRCUMFLEX);
	advancewindow();
	sb1 = sb2 = subscripts;
	ox = 0;
	if (shifting = TREF(shift_side_effects))
	{
		dqinit(&tmpchain, exorder);
		oldchain = setcurtchain(&tmpchain);
	}
	if (window_token == TK_LBRACKET || window_token == TK_VBAR)
	{	vbar = (window_token == TK_VBAR);
		advancewindow();
		if (vbar)
			parse_status = expr(sb1++);
		else
			parse_status = expratom(sb1++);
		if (!parse_status)
		{	stx_error(ERR_EXPR);
			if (shifting)
				setcurtchain(oldchain);
			return FALSE;
		}
		if (window_token == TK_COMMA)
		{
			advancewindow();
			if (vbar)
				parse_status = expr(sb1++);
			else
				parse_status = expratom(sb1++);
			if (!parse_status)
			{	stx_error(ERR_EXPR);
				if (shifting)
					setcurtchain(oldchain);
				return FALSE;
			}
		} else
			*sb1++ = put_str(0,0);
		if ((!vbar && window_token != TK_RBRACKET) || (vbar && window_token != TK_VBAR))
		{	stx_error(ERR_EXTGBLDEL);
			if (shifting)
				setcurtchain(oldchain);
			return FALSE;
		}
		advancewindow();
		ox = OC_GVEXTNAM;
	}
	if (window_token == TK_IDENT)
	{
		if (!ox)
			ox = OC_GVNAME;
		*sb1++ = put_str(window_ident.addr, window_ident.len);
		advancewindow();
	} else
	{	if (ox)
		{
			stx_error(ERR_GVNAKEDEXTNM);
			if (shifting)
				setcurtchain(oldchain);
			return FALSE;
		}
		if (window_token != TK_LPAREN)
		{
			stx_error(ERR_GBLNAME);
			if (shifting)
				setcurtchain(oldchain);
			return FALSE;
		}
		ox = OC_GVNAKED;
	}
	if (window_token == TK_LPAREN)
		for (;;)
		{
			if (sb1 >= ARRAYTOP(subscripts))
			{
				stx_error(ERR_MAXNRSUBSCRIPTS);
				if (shifting)
					setcurtchain(oldchain);
				return FALSE;
			}
			advancewindow();
			if (!expr(sb1))
			{
				if (shifting)
					setcurtchain(oldchain);
				return FALSE;
			}
			assert(sb1->oprclass == TRIP_REF);
			s = sb1->oprval.tref;
			if (s->opcode == OC_LIT)
				*sb1 = make_gvsubsc(&s->operand[0].oprval.mlit->v);
			sb1++;
			if ((x = window_token) == TK_RPAREN)
			{
				advancewindow();
				break;
			}
			if (x != TK_COMMA)
			{
				stx_error(ERR_RPARENMISSING);
				if (shifting)
					setcurtchain(oldchain);
				return FALSE;
			}
		}
	ref = newtriple(ox);
	ref->operand[0] = put_ilit((mint)(sb1 - sb2));
	for ( ; sb2 < sb1 ; sb2++)
	{
		t1 = newtriple(OC_PARAMETER);
		ref->operand[1] = put_tref(t1);
		ref = t1;
		ref->operand[0] = *sb2;
	}
	if (shifting)
	{
		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));
	}
	return TRUE;
}
示例#10
0
int m_merge(void)
{
	error_def(ERR_VAREXPECTED);
	error_def(ERR_RPARENMISSING);
	error_def(ERR_EQUAL);

	opctype 	put_oc;
	oprtype 	mopr;
	triple		*sub, *ref,  *obp, *s1, *restart, tmpchain;
	mval		mv;
	int		type;

	restart = newtriple(OC_RESTARTPC);	/* Here is where a restart should pick up */

	dqinit(&tmpchain, exorder);
	/* Left Hand Side of EQUAL sign */
	switch (window_token)
	{
        case TK_IDENT:
                if (!lvn(&mopr, OC_PUTINDX, 0))
                        return FALSE;
		if (OC_PUTINDX == mopr.oprval.tref->opcode);
		{
			/* we insert left hand side argument into tmpchain. */
			dqdel(mopr.oprval.tref, exorder);
			dqins(tmpchain.exorder.bl, exorder, mopr.oprval.tref);
		}
		ref = maketriple(OC_MERGE_LVARG);
		ref->operand[0] = put_ilit(MARG1_LCL);
		ref->operand[1] = mopr;
		dqins(tmpchain.exorder.bl, exorder, ref);
                break;
        case TK_CIRCUMFLEX:
		s1 = curtchain->exorder.bl;
                if (!gvn())
                        return FALSE;
		for (sub = curtchain->exorder.bl; sub != s1; sub = sub->exorder.bl)
		{
			put_oc = sub->opcode;
			if (OC_GVNAME == put_oc || OC_GVNAKED == put_oc || OC_GVEXTNAM == put_oc)
				break;
		}
		assert(OC_GVNAME == put_oc || OC_GVNAKED == put_oc || OC_GVEXTNAM == put_oc);
		/* we insert left hand side argument into tmpchain. */
		dqdel(sub, exorder);
		dqins(tmpchain.exorder.bl ,exorder, sub);
		ref = maketriple(OC_MERGE_GVARG);
		ref->operand[0] = put_ilit(MARG1_GBL);
		dqins(tmpchain.exorder.bl, exorder, ref);
                break;
        case TK_ATSIGN:
                if (!indirection(&mopr))
                        return FALSE;
		if (window_token != TK_EQUAL)
		{
			ref = newtriple(OC_COMMARG);
			ref->operand[0] = mopr;
                	ref->operand[1] = put_ilit((mint) indir_merge);
			ins_triple(ref);
			return TRUE;
		}
		type = MARG1_LCL | MARG1_GBL;
		MV_FORCE_MVAL(&mv, type);
		MV_FORCE_STR(&mv);
                ref = maketriple(OC_INDMERGE);
                ref->operand[0] = put_lit(&mv);
                ref->operand[1] = mopr;
		/* we insert left hand side argument into tmpchain. */
		dqins(tmpchain.exorder.bl, exorder, ref);
                break;
	default:
		stx_error(ERR_VAREXPECTED);
		return FALSE;
	}

	if (window_token != TK_EQUAL)
	{
		stx_error(ERR_EQUAL);
		return FALSE;
	}
	advancewindow();

	/* Right Hand Side of EQUAL sign */
	switch (window_token)
	{
        case TK_IDENT:
                if (!lvn(&mopr, OC_M_SRCHINDX, 0))
                        return FALSE;
		ref = newtriple(OC_MERGE_LVARG);
		ref->operand[0] = put_ilit(MARG2_LCL);
		ref->operand[1] = mopr;
		break;
        case TK_CIRCUMFLEX:
                if (!gvn())
                        return FALSE;
		ref = newtriple(OC_MERGE_GVARG);
		ref->operand[0] = put_ilit(MARG2_GBL);
		break;
        case TK_ATSIGN:
                if (!indirection(&mopr))
		{
			stx_error(ERR_VAREXPECTED);
                        return FALSE;
		}
		type = MARG2_LCL | MARG2_GBL;
		MV_FORCE_MVAL(&mv, type);
		MV_FORCE_STR(&mv);
                ref = maketriple(OC_INDMERGE);
                ref->operand[0] =  put_lit(&mv);
                ref->operand[1] = mopr;
                ins_triple(ref);
		break;
	default:
		stx_error(ERR_VAREXPECTED);
		return FALSE;
	}
	/*
	 * Make sure that during runtime right hand side argument is processed first.
	 * This is specially important if global naked variable is used .
	 */
	obp = curtchain->exorder.bl;
	dqadd(obp, &tmpchain, exorder);
	ref = newtriple(OC_MERGE);
	return TRUE;
}
示例#11
0
int f_select(oprtype *a, opctype op)
{
	boolean_t	first_time, save_saw_side, save_shift;
	unsigned int	save_depth;
	opctype		old_op;
	oprtype		*cnd, endtrip, target, tmparg;
	triple		*oldchain, *r, *ref, *save_start, *save_start_orig, tmpchain, *triptr;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	save_shift = TREF(shift_side_effects);
	save_saw_side = TREF(saw_side_effect);
	save_depth = TREF(expr_depth);
	save_start = TREF(expr_start);
	save_start_orig = TREF(expr_start_orig);
	TREF(shift_side_effects) = FALSE;
	TREF(saw_side_effect) = FALSE;
	TREF(expr_depth) = 0;
	TREF(expr_start) = TREF(expr_start_orig) = NULL;
	if (save_shift)
	{
		dqinit(&tmpchain, exorder);
		oldchain = setcurtchain(&tmpchain);
	}
	r = maketriple(op);
	first_time = TRUE;
	endtrip = put_tjmp(r);
	for (;;)
	{
		cnd = (oprtype *)mcalloc(SIZEOF(oprtype));
		if (!bool_expr(FALSE, cnd))
		{
			if (save_shift)
				setcurtchain(oldchain);
			return FALSE;
		}
		if (TK_COLON != TREF(window_token))
		{
			if (save_shift)
				setcurtchain(oldchain);
			stx_error(ERR_COLON);
			return FALSE;
		}
		advancewindow();
		if (EXPR_FAIL == expr(&tmparg, MUMPS_EXPR))
		{
			if (save_shift)
				setcurtchain(oldchain);
			return FALSE;
		}
		assert(TRIP_REF == tmparg.oprclass);
		old_op = tmparg.oprval.tref->opcode;
		if (first_time)
		{
			if ((OC_LIT == old_op) || (oc_tab[old_op].octype & OCT_MVADDR))
			{
				ref = newtriple(OC_STOTEMP);
				ref->operand[0] = tmparg;
				tmparg = put_tref(ref);
			}
			r->operand[0] = target = tmparg;
			first_time = FALSE;
		} else
		{
			ref = newtriple(OC_STO);
			ref->operand[0] = target;
			ref->operand[1] = tmparg;
			if (OC_PASSTHRU == tmparg.oprval.tref->opcode)
			{
				assert(TRIP_REF == tmparg.oprval.tref->operand[0].oprclass);
				ref = newtriple(OC_STO);
				ref->operand[0] = target;
				ref->operand[1] = put_tref(tmparg.oprval.tref->operand[0].oprval.tref);
			}
		}
		ref = newtriple(OC_JMP);
		ref->operand[0] = endtrip;
		tnxtarg(cnd);
		if (TK_COMMA != TREF(window_token))
			break;
		advancewindow();
	}
	tmparg = put_ilit(ERR_SELECTFALSE);
	ref = newtriple(OC_RTERROR);
	ref->operand[0] = tmparg;
	ref->operand[1] = put_ilit(FALSE);	/* Not a subroutine reference */
	ins_triple(r);
	assert(!TREF(expr_depth));
	TREF(shift_side_effects) = save_shift;
	TREF(saw_side_effect) = save_saw_side;
	TREF(expr_depth) = save_depth;
	TREF(expr_start) = save_start;
	TREF(expr_start_orig) = save_start_orig;
	if (save_shift)
	{
		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;
}
示例#12
0
int m_set(void)
{
	/* Some comment on "parse_warn". It is set to TRUE whenever the parse encounters an
	   invalid setleft target.

	   * Note that even if "parse_warn" is TRUE, we should not return FALSE right away but need to continue the parse
	   * until the end of the current SET command. This way any remaining commands in the current parse line will be
	   * parsed and triples generated for them. This is necessary just in case the currently parsed invalid SET command
	   * does not get executed at runtime (due to postconditionals etc.)
	   *
	   * Some comment on the need for "first_setleft_invalid". This variable is needed only in the
	   * case we encounter an invalid-SVN/invalid-FCN/unsettable-SVN as a target of the SET. We need to evaluate the
	   * right-hand-side of the SET command only if at least one valid setleft target is parsed before an invalid setleft
	   * target is encountered. This is because we still need to execute the valid setlefts at runtime before triggering
	   * a runtime error for the invalid setleft. If the first setleft target is an invalid one, then there is no need
	   * to evaluate the right-hand-side. In fact, in this case, adding triples (corresponding to the right hand side)
	   * to the execution chain could cause problems with emit_code later in the compilation as the destination
	   * for the right hand side triples could now be undefined (for example a valid SVN on the left side of the
	   * SET would have generated an OC_SVPUT triple with one of its operands holding the result of the right
	   * hand side evaluation, but an invalid SVN on the left side which would have instead caused an OC_RTERROR triple
	   * to have been generated leaving no triple to receive the result of the right hand side evaluation thus causing
	   * emit_code to be confused and GTMASSERT). Therefore discard all triples generated by the right hand side in this case.
	   * By the same reasoning, discard all triples generated by setleft targets AFTER this invalid one as well.
	   * "first_setleft_invalid" is set to TRUE if the first setleft target is invalid and set to FALSE if the first setleft
	   * target is valid. It is initialized to -1 before the start of the parse.
	   */

	int		index, setop, delimlen;
	int		first_val_lit, last_val_lit, nakedzalias;
	boolean_t	first_is_lit, last_is_lit, got_lparen, delim1char, is_extract, valid_char;
	boolean_t 	alias_processing, have_lh_alias;
	opctype		put_oc;
	oprtype		v, delimval, firstval, lastval, *result, resptr;
	triple		*curtargchain, *delimiter, discardcurtchain, *first, *get, *jmptrp1, *jmptrp2, *last, *obp, *put;
	triple		*s, *s0, *s1, save_targchain, *save_curtchain, *save_curtchain1, *sub, targchain, *tmp;
	mint		delimlit;
	mval		*delim_mval;
	mvar		*mvarptr;
	boolean_t	parse_warn;	/* set to TRUE in case of an invalid SVN etc. */
	boolean_t	curtchain_switched;	/* set to TRUE if a setcurtchain was done */
	int		first_setleft_invalid;	/* set to TRUE if the first setleft target is invalid */
	boolean_t	temp_subs_was_FALSE;
	union
	{
		uint4		unichar_val;
		unsigned char	unibytes_val[4];
	} unichar;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	TREF(temp_subs) = FALSE;
	dqinit(&targchain, exorder);
	result = (oprtype *)mcalloc(SIZEOF(oprtype));
	resptr = put_indr(result);
	delimiter = sub = last = NULL;
	/* A SET clause must be entirely alias related or a normal set. Parenthized multiple sets of aliases are not allowed
	 * and will trigger an error. This is because the source and targets of aliases require different values and references
	 * than normal sets do and thus cannot be mixed.
	 */
	if (alias_processing = (TK_ASTERISK == window_token))
		advancewindow();
	if (got_lparen = (TK_LPAREN == window_token))
	{
		if (alias_processing)
			stx_error(ERR_NOALIASLIST);
		advancewindow();
		TREF(temp_subs) = TRUE;
	}
	/* Some explanation: The triples from the left hand side of the SET expression that are
	 * expressly associated with fetching (in case of set $piece/$extract) and/or storing of
	 * the target value are removed from curtchain and placed on the targchain. Later, these
	 * triples will be added to the end of curtchain to do the finishing store of the target
	 * after the righthand side has been evaluated. This is per the M standard.
	 *
	 * Note that SET $PIECE/$EXTRACT have special conditions in which the first argument is not referenced at all.
	 * (e.g. set $piece(^a," ",3,2) in this case 3 > 2 so this should not evaluate ^a and therefore should not
	 * modify the naked indicator). That is, the triples that do these conditional checks need to be inserted
	 * ahead of the OC_GVNAME of ^a, all of which need to be inserted on the targchain. But the conditionalization
	 * can be done only after parsing the first argument of the SET $PIECE and examining the remaining arguments.
	 * Therefore we maintain the "curtargchain" variable which stores the value of the "targchain" at the beginning
	 * of the iteration (at the start of the $PIECE parsing) and all the conditionalization will be inserted right
	 * here which is guaranteed to be ahead of where the OC_GVNAME gets inserted.
	 *
	 * For example, SET $PIECE(^A(x,y),delim,first,last)=RHS will generate a final triple chain as follows
	 *
	 *	A - Triples to evaluate subscripts (x,y) of the global ^A
	 *	A - Triples to evaluate delim
	 *	A - Triples to evaluate first
	 *	A - Triples to evaluate last
	 *	B - Triples to evaluate RHS
	 *	C - Triples to do conditional check (e.g. first > last etc.)
	 *	C - Triples to branch around if the checks indicate this is a null operation SET $PIECE
	 *	D - Triple that does OC_GVNAME of ^A
	 *	D - Triple that does OC_SETPIECE to determine the new value
	 *	D - Triple that does OC_GVPUT of the new value into ^A(x,y)
	 *	This is the point where the conditional check triples will branch around to if they chose to.
	 *
	 *	A - triples that evaluates the arguments/subscripts in the left-hand-side of the SET command
	 *		These triples are built in "curtchain"
	 *	B - triples that evaluates the arguments/subscripts in the right-hand-side of the SET command
	 *		These triples are built in "curtchain"
	 *	C - triples that do conditional check for any $PIECE/$EXTRACT in the left side of the SET command.
	 *		These triples are built in "curtargchain"
	 *	D - triples that generate the reference to the target of the SET and the store into the target.
	 *		These triples are built in "targchain"
	 *
	 * Note alias processing does not support the SET *(...)=.. type syntax because the type of argument
	 * created for RHS processing is dependent on the LHS receiver type and we do not support more than one
	 * type of source argument in a single SET.
	 */
	first_setleft_invalid = FIRST_SETLEFT_NOTSEEN;
	curtchain_switched = FALSE;
	nakedzalias = have_lh_alias = FALSE;
	save_curtchain = NULL;
	assert(FIRST_SETLEFT_NOTSEEN != TRUE);
	assert(FIRST_SETLEFT_NOTSEEN != FALSE);
	for (parse_warn = FALSE; ; parse_warn = FALSE)
	{
		curtargchain = targchain.exorder.bl;
		jmptrp1 = jmptrp2 = NULL;
		delim1char = is_extract = FALSE;
		allow_dzwrtac_as_mident();	/* Allows $ZWRTACxxx as target to be treated as an mident */
		switch (window_token)
		{
			case TK_IDENT:
				/* A slight diversion first. If this is a $ZWRTAC set (indication of $ in first char
				 * is currently enough to signify that), then we need to check a few conditions first.
				 * If this is a "naked $ZWRTAC", meaning no numeric suffix, then this is a flag that
				 * all the $ZWRTAC vars in the local variable tree need to be kill *'d which will not
				 * be generating a SET instruction. First we need to verify that fact and make sure
				 * we are not in PARENs and not doing alias processing. Note *any* value can be
				 * specified as the source but while it will be evaluated, it is NOT stored anywhere.
				 */
				if ('$' == *window_ident.addr)
				{	/* We have a $ZWRTAC<xx> target */
					if (got_lparen)
						/* We don't allow $ZWRTACxxx to be specified in a parenthesized list.
						 * Verify that first
						 */
						SYNTAX_ERROR(ERR_DZWRNOPAREN);
					if (STR_LIT_LEN(DOLLAR_ZWRTAC) == window_ident.len)
					{	/* Ok, this is a naked $ZWRTAC targeted set */
						if (alias_processing)
							SYNTAX_ERROR(ERR_DZWRNOALIAS);
						nakedzalias = TRUE;
						/* This opcode doesn't really need args but it is easier to fit in with the rest
						 * of m_set processing to pass it the result arg, which there may actually be
						 * a use for someday..
						 */
						put = maketriple(OC_CLRALSVARS);
						put->operand[0] = resptr;
						dqins(targchain.exorder.bl, exorder, put);
						advancewindow();
						break;
					}
				}
				/* If we are doing alias processing, there are two possibilities:
				 *  1) LHS is unsubscripted - it is an alias variable being created or replaced. Need to parse
				 *  the varname as if this were a regular set.
				 *  2) LHS is subscripted - it is an alias container variable being created or replaced. The
				 *  processing here is to pass the base variable index to the store routine so bypass the
				 *  lvn() call.
				 */
				if (!alias_processing || TK_LPAREN == director_token)
				{	/* Normal variable processing or we have a lh alias container */
					if (!lvn(&v, OC_PUTINDX, 0))
						SYNTAX_ERROR_NOREPORT_HERE;
					if (OC_PUTINDX == v.oprval.tref->opcode)
					{
						dqdel(v.oprval.tref, exorder);
						dqins(targchain.exorder.bl, exorder, v.oprval.tref);
						sub = v.oprval.tref;
						put_oc = OC_PUTINDX;
						if (TREF(temp_subs))
							m_set_create_temporaries(sub, put_oc);
					}
				} else
				{	/* Have alias variable. Argument is index into var table rather than pointer to var */
					have_lh_alias = TRUE;
					/* We only want the variable index in this case. Since the entire hash structure to which
					 * this variable is going to be pointing to is changing, doing anything that calls fetch()
					 * is somewhat pointless so we avoid it by just accessing the variable information
					 * directly.
					 */
					mvarptr = get_mvaddr(&window_ident);
					v = put_ilit(mvarptr->mvidx);
					advancewindow();
				}
				/* Determine correct storing triple */
				put = maketriple((!alias_processing ? OC_STO :
						  (have_lh_alias ? OC_SETALS2ALS : OC_SETALSIN2ALSCT)));
				put->operand[0] = v;
				put->operand[1] = resptr;
				dqins(targchain.exorder.bl, exorder, put);
				break;
			case TK_CIRCUMFLEX:
				if (alias_processing)
					SYNTAX_ERROR(ERR_ALIASEXPECTED);
				s1 = curtchain->exorder.bl;
				if (!gvn())
					SYNTAX_ERROR_NOREPORT_HERE;
				for (sub = curtchain->exorder.bl; sub != s1; sub = sub->exorder.bl)
				{
					put_oc = sub->opcode;
					if (OC_GVNAME == put_oc || OC_GVNAKED == put_oc || OC_GVEXTNAM == put_oc)
						break;
				}
				assert(OC_GVNAME == put_oc || OC_GVNAKED == put_oc || OC_GVEXTNAM == put_oc);
				dqdel(sub, exorder);
				dqins(targchain.exorder.bl, exorder, sub);
				if (TREF(temp_subs))
					m_set_create_temporaries(sub, put_oc);
				put = maketriple(OC_GVPUT);
				put->operand[0] = resptr;
				dqins(targchain.exorder.bl, exorder, put);
				break;
			case TK_ATSIGN:
				if (alias_processing)
					SYNTAX_ERROR(ERR_ALIASEXPECTED);
				if (!indirection(&v))
					SYNTAX_ERROR_NOREPORT_HERE;
				if (!got_lparen && TK_EQUAL != window_token)
				{
					assert(!curtchain_switched);
					put = newtriple(OC_COMMARG);
					put->operand[0] = v;
					put->operand[1] = put_ilit(indir_set);
					return TRUE;
				}
				put = maketriple(OC_INDSET);
				put->operand[0] = v;
				put->operand[1] = resptr;
				dqins(targchain.exorder.bl, exorder, put);
				break;
			case TK_DOLLAR:
				if (alias_processing)
					SYNTAX_ERROR(ERR_ALIASEXPECTED);
				advancewindow();
				if (TK_IDENT != window_token)
					SYNTAX_ERROR(ERR_VAREXPECTED);
				if (TK_LPAREN != director_token)
				{	/* Look for intrinsic special variables */
					s1 = curtchain->exorder.bl;
					if (0 > (index = namelook(svn_index, svn_names, window_ident.addr, window_ident.len)))
					{
						STX_ERROR_WARN(ERR_INVSVN);	/* sets "parse_warn" to TRUE */
					} else if (!svn_data[index].can_set)
					{
						STX_ERROR_WARN(ERR_SVNOSET);	/* sets "parse_warn" to TRUE */
					}
					advancewindow();
					if (!parse_warn)
					{
						if (SV_ETRAP != svn_data[index].opcode && SV_ZTRAP != svn_data[index].opcode)
						{	/* Setting of $ZTRAP or $ETRAP must go through opp_svput because they
							 * may affect the stack pointer. All others directly to op_svput().
							 */
							put = maketriple(OC_SVPUT);
						} else
							put = maketriple(OC_PSVPUT);
						put->operand[0] = put_ilit(svn_data[index].opcode);
						put->operand[1] = resptr;
						dqins(targchain.exorder.bl, exorder, put);
					} else
					{	/* OC_RTERROR triple would have been inserted in curtchain by ins_errtriple
						 * (invoked by stx_error). To maintain consistency with the "if" portion of
						 * this code, we need to move this triple to the "targchain".
						 */
						tmp = curtchain->exorder.bl; /* corresponds to put_ilit(FALSE) in ins_errtriple */
						tmp = tmp->exorder.bl;	/* corresponds to put_ilit(in_error) in ins_errtriple */
						tmp = tmp->exorder.bl;	/* corresponds to newtriple(OC_RTERROR) in ins_errtriple */
						assert(OC_RTERROR == tmp->opcode);
						dqdel(tmp, exorder);
						dqins(targchain.exorder.bl, exorder, tmp);
						CHKTCHAIN(&targchain);
					}
					break;
				}
				/* Only 4 function names allowed on left side: $[Z]Piece and $[Z]Extract */
				index = namelook(fun_index, fun_names, window_ident.addr, window_ident.len);
				if (0 > index)
				{
					STX_ERROR_WARN(ERR_INVFCN);	/* sets "parse_warn" to TRUE */
					/* OC_RTERROR triple would have been inserted in "curtchain" by ins_errtriple
					 * (invoked by stx_error). We need to switch it to "targchain" to be consistent
					 * with every other codepath in this module.
					 */
					tmp = curtchain->exorder.bl; /* corresponds to put_ilit(FALSE) in ins_errtriple */
					tmp = tmp->exorder.bl;	/* corresponds to put_ilit(in_error) in ins_errtriple */
					tmp = tmp->exorder.bl;	/* corresponds to newtriple(OC_RTERROR) in ins_errtriple */
					assert(OC_RTERROR == tmp->opcode);
					dqdel(tmp, exorder);
					dqins(targchain.exorder.bl, exorder, tmp);
					CHKTCHAIN(&targchain);
					advancewindow();	/* skip past the function name */
					advancewindow();	/* skip past the left paren */
					/* Parse the remaining arguments until corresponding RIGHT-PAREN/SPACE/EOL is reached */
					if (!parse_until_rparen_or_space())
						SYNTAX_ERROR_NOREPORT_HERE;
				} else
				{
					switch(fun_data[index].opcode)
					{
						case OC_FNPIECE:
							setop = OC_SETPIECE;
							break;
						case OC_FNEXTRACT:
							is_extract = TRUE;
							setop = OC_SETEXTRACT;
							break;
						case OC_FNZPIECE:
							setop = OC_SETZPIECE;
							break;
						case OC_FNZEXTRACT:
							is_extract = TRUE;
							setop = OC_SETZEXTRACT;
							break;
						default:
							SYNTAX_ERROR(ERR_VAREXPECTED);
					}
					advancewindow();
					advancewindow();
					/* Although we see the get (target) variable first, we need to save it's processing
					 * on another chain -- the targchain -- because the retrieval of the target is bypassed
					 * and the naked indicator is not reset if the first/last parameters are not set in a
					 * logical manner (must be > 0 and first <= last). So the evaluation order is
					 * delimiter (if $piece), first, last, RHS of the set and then the target if applicable.
					 * Set up primary action triple now since it is ref'd by the put triples generated below.
					 */
					s = maketriple(setop);
					/* Even for SET[Z]PIECE and SET[Z]EXTRACT, the SETxxxxx opcodes
					 * do not do the final store, they only create the final value TO be
					 * stored so generate the triples that will actually do the store now.
					 * Note we are still building triples on the original curtchain.
					 */
					switch (window_token)
					{
						case TK_IDENT:
							if (!lvn(&v, OC_PUTINDX, 0))
								SYNTAX_ERROR(ERR_VAREXPECTED);
							if (OC_PUTINDX == v.oprval.tref->opcode)
							{
								dqdel(v.oprval.tref, exorder);
								dqins(targchain.exorder.bl, exorder, v.oprval.tref);
								sub = v.oprval.tref;
								put_oc = OC_PUTINDX;
								if (TREF(temp_subs))
									m_set_create_temporaries(sub, put_oc);
							}
							get = maketriple(OC_FNGET);
							get->operand[0] = v;
							put = maketriple(OC_STO);
							put->operand[0] = v;
							put->operand[1] = put_tref(s);
							break;
						case TK_ATSIGN:
							if (!indirection(&v))
								SYNTAX_ERROR(ERR_VAREXPECTED);
							get = maketriple(OC_INDGET);
							get->operand[0] = v;
							get->operand[1] = put_str(0, 0);
							put = maketriple(OC_INDSET);
							put->operand[0] = v;
							put->operand[1] = put_tref(s);
							break;
						case TK_CIRCUMFLEX:
							s1 = curtchain->exorder.bl;
							if (!gvn())
								SYNTAX_ERROR_NOREPORT_HERE;
							for (sub = curtchain->exorder.bl; sub != s1 ; sub = sub->exorder.bl)
							{
								put_oc = sub->opcode;
								if ((OC_GVNAME == put_oc) || (OC_GVNAKED == put_oc)
								    || (OC_GVEXTNAM == put_oc))
									break;
							}
							assert((OC_GVNAME == put_oc) || (OC_GVNAKED == put_oc)
							       || (OC_GVEXTNAM == put_oc));
							dqdel(sub, exorder);
							dqins(targchain.exorder.bl, exorder, sub);
							if (TREF(temp_subs))
								m_set_create_temporaries(sub, put_oc);
							get = maketriple(OC_FNGVGET);
							get->operand[0] = put_str(0, 0);
							put = maketriple(OC_GVPUT);
							put->operand[0] = put_tref(s);
							break;
						default:
							SYNTAX_ERROR(ERR_VAREXPECTED);
					}
					s->operand[0] = put_tref(get);
					/* Code to fetch args for target triple are on targchain. Put get there now too. */
					dqins(targchain.exorder.bl, exorder, get);
					CHKTCHAIN(&targchain);
					if (!is_extract)
					{	/* Set $[z]piece */
						delimiter = newtriple(OC_PARAMETER);
						s->operand[1] = put_tref(delimiter);
						first = newtriple(OC_PARAMETER);
						delimiter->operand[1] = put_tref(first);
						/* Process delimiter string ($[z]piece only) */
						if (TK_COMMA != window_token)
							SYNTAX_ERROR(ERR_COMMA);
						advancewindow();
						if (!strexpr(&delimval))
							SYNTAX_ERROR_NOREPORT_HERE;
						assert(TRIP_REF == delimval.oprclass);
					} else
					{	/* Set $[Z]Extract */
						first = newtriple(OC_PARAMETER);
						s->operand[1] = put_tref(first);
					}
					/* Process first integer value */
					if (window_token != TK_COMMA)
						firstval = put_ilit(1);
					else
					{
						advancewindow();
						if (!intexpr(&firstval))
							SYNTAX_ERROR(ERR_COMMA);
						assert(firstval.oprclass == TRIP_REF);
					}
					first->operand[0] = firstval;
					if (first_is_lit = (OC_ILIT == firstval.oprval.tref->opcode))
					{
						assert(ILIT_REF ==firstval.oprval.tref->operand[0].oprclass);
						first_val_lit = firstval.oprval.tref->operand[0].oprval.ilit;
					}
					if (TK_COMMA != window_token)
					{	/* There is no "last" value. Only if 1 char literal delimiter and
						 * no "last" value can we generate shortcut code to op_set[z]p1 entry
						 * instead of op_set[z]piece. Note if UTF8 mode is in effect, then this
						 * optimization applies if the literal is one unicode char which may in
						 * fact be up to 4 bytes but will still be passed as a single unsigned
						 * integer.
						 */
						if (!is_extract)
						{
							delim_mval = &delimval.oprval.tref->operand[0].oprval.mlit->v;
							valid_char = TRUE;	/* Basic assumption unles proven otherwise */
							if (delimval.oprval.tref->opcode == OC_LIT &&
							    (1 == (gtm_utf8_mode ?
								   MV_FORCE_LEN(delim_mval) : delim_mval->str.len)))
							{	/* Single char delimiter for set $piece */
								UNICODE_ONLY(
									if (gtm_utf8_mode)
									{	/*  We have a supposed single char delimiter but it
										 *  must be a valid utf8 char to be used by
										 *  op_setp1() and MV_FORCE_LEN won't tell us that.
										 */
										valid_char = UTF8_VALID(delim_mval->str.addr,
													(delim_mval->str.addr
													 + delim_mval->str.len),
													delimlen);
										if (!valid_char && !badchar_inhibit)
											UTF8_BADCHAR(0, delim_mval->str.addr,
												     (delim_mval->str.addr
												      + delim_mval->str.len),
												     0, NULL);
									}
									     );
								if (valid_char || 1 == delim_mval->str.len)
								{	/* This reference to a one character literal or a single
									 * byte invalid utf8 character that needs to be turned into
									 * an explict formated integer literal instead
									 */
									unichar.unichar_val = 0;
									if (!gtm_utf8_mode)
									{	/* Single byte delimiter */
										assert(1 == delim_mval->str.len);
										UNIX_ONLY(s->opcode = OC_SETZP1);
										VMS_ONLY(s->opcode = OC_SETP1);
										unichar.unibytes_val[0] = *delim_mval->str.addr;
									}
									UNICODE_ONLY(
								        else
									{	/* Potentially multiple bytes in one int */
										assert(SIZEOF(int) >= delim_mval->str.len);
										memcpy(unichar.unibytes_val,
										       delim_mval->str.addr,
										       delim_mval->str.len);
										s->opcode = OC_SETP1;
									}
										     );
									delimlit = (mint)unichar.unichar_val;
									delimiter->operand[0] = put_ilit(delimlit);
									delim1char = TRUE;
								}
							}
						}
示例#13
0
int m_zgoto(void)
{
	triple		tmpchain, *oldchain, *obp, *ref0, *ref1, *triptr;
	oprtype		*cr, quits;
	int4		rval;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	dqinit(&tmpchain, exorder);
	oldchain = setcurtchain(&tmpchain);
	if ((TK_EOL == window_token) || (TK_SPACE == window_token))
	{	/* Default zgoto level is 1 */
		quits = put_ilit(1);
		rval = EXPR_GOOD;
	} else if (!(rval = intexpr(&quits)))		/* note assignment */
	{
		setcurtchain(oldchain);
		return FALSE;
	}
	if ((EXPR_INDR != rval) && ((TK_EOL == window_token) || (TK_SPACE == window_token)))
	{	/* Only level parm supplied (no entry ref) - job for op_zg1 */
		setcurtchain(oldchain);
		obp = oldchain->exorder.bl;
		dqadd(obp, &tmpchain, exorder);		/* this is a violation of info hiding */
		ref0 = newtriple(OC_ZG1);
		ref0->operand[0] = quits;
		return TRUE;
	}
	if (TK_COLON != window_token)
	{	/* First arg parsed, not ending in ":". Better have been indirect */
		setcurtchain(oldchain);
		if (EXPR_INDR != rval)
		{
			stx_error(ERR_COLON);
			return FALSE;
		}
		make_commarg(&quits, indir_zgoto);
		obp = oldchain->exorder.bl;
		dqadd(obp, &tmpchain, exorder);		/* this is a violation of info hiding */
	 	return TRUE;
	}
	advancewindow();
	if (TK_COLON != window_token)
	{
		if (!entryref(OC_NOOP, OC_PARAMETER, (mint)indir_goto, FALSE, FALSE, TRUE))
		{
			setcurtchain(oldchain);
			return FALSE;
		}
		ref0 = maketriple(OC_ZGOTO);
		ref0->operand[0] = quits;
		ref0->operand[1] = put_tref(tmpchain.exorder.bl);
		ins_triple(ref0);
		setcurtchain(oldchain);
	} else
	{
		ref0 = maketriple(OC_ZG1);
		ref0->operand[0] = quits;
		ins_triple(ref0);
		setcurtchain(oldchain);
	}
	if (TK_COLON == window_token)
	{	/* post conditional expression */
		advancewindow();
		cr = (oprtype *)mcalloc(SIZEOF(oprtype));
		if (!bool_expr((bool)FALSE, cr))
			return FALSE;
		if (TREF(expr_start) != TREF(expr_start_orig))
		{
			triptr = newtriple(OC_GVRECTARG);
			triptr->operand[0] = put_tref(TREF(expr_start));
		}
		obp = oldchain->exorder.bl;
		dqadd(obp, &tmpchain, exorder);		 /* this is a violation of info hiding */
		if (TREF(expr_start) != TREF(expr_start_orig))
		{
			ref0 = newtriple(OC_JMP);
			ref1 = newtriple(OC_GVRECTARG);
			ref1->operand[0] = put_tref(TREF(expr_start));
			*cr = put_tjmp(ref1);
			tnxtarg(&ref0->operand[0]);
		} else
			tnxtarg(cr);
		return TRUE;
	}
	obp = oldchain->exorder.bl;
	dqadd(obp, &tmpchain, exorder);			/* this is a violation of info hiding */
	return TRUE;
}
示例#14
0
文件: m_if.c 项目: 5HT/mumps
int m_if(void)
{
	triple *ref0, *ref1, *ref2, *jmpref, ifpos_in_chain, *triptr;
	oprtype x, y, *ta_opr;
	bool first_time, t_set, is_commarg;

	typedef struct jmpchntype
	{	struct
		{	struct jmpchntype *fl,*bl;
		}link;
		triple  *jmptrip;
	}jmpchn;
	jmpchn *jmpchain,*nxtjmp;

	error_def(ERR_SPOREOL);
	error_def(ERR_INDEXTRACHARS);

	ifpos_in_chain = pos_in_chain;
	jmpchain = (jmpchn*) mcalloc(sizeof(jmpchn));
	dqinit(jmpchain,link);
	if (window_token == TK_EOL)
		return TRUE;
	is_commarg = last_source_column == 1;
	x = for_end_of_scope(0);
	assert(x.oprclass == INDR_REF);
	if (window_token == TK_SPACE)
	{	jmpref = newtriple(OC_JMPTCLR);
		jmpref->operand[0] = x;
		nxtjmp = (jmpchn *) mcalloc(sizeof(jmpchn));
		nxtjmp->jmptrip = jmpref;
		dqins(jmpchain,link,nxtjmp);
	}
	else
	{
		first_time = TRUE;
		for (;;)
		{
			ta_opr = (oprtype *) mcalloc(sizeof(oprtype));
			if (!bool_expr((bool) TRUE, ta_opr))
				return FALSE;
			if ((ref0 = curtchain->exorder.bl)->opcode == OC_JMPNEQ
				&& (ref1 = ref0->exorder.bl)->opcode == OC_COBOOL
				&& (ref2 = ref1->exorder.bl)->opcode == OC_INDGLVN)
			{
				dqdel(ref0,exorder);
				ref1->opcode = OC_JMPTSET;
				ref1->operand[0] = put_indr(ta_opr);
				ref2->opcode = OC_COMMARG;
				ref2->operand[1] = put_ilit((mint) indir_if);
			}
			t_set = curtchain->exorder.bl->opcode == OC_JMPTSET;
			if (!t_set)
				newtriple(OC_CLRTEST);
			if (expr_start != expr_start_orig)
			{
                		triptr = newtriple(OC_GVRECTARG);
				triptr->operand[0] = put_tref(expr_start);
			}
			jmpref = newtriple(OC_JMP);
			jmpref->operand[0] = x;
			nxtjmp = (jmpchn *) mcalloc(sizeof(jmpchn));
			nxtjmp->jmptrip = jmpref;
			dqins(jmpchain,link,nxtjmp);
			tnxtarg(ta_opr);
			if (first_time)
			{
				if (!t_set)
					newtriple(OC_SETTEST);
				if (expr_start != expr_start_orig)
				{
					triptr = newtriple(OC_GVRECTARG);
					triptr->operand[0] = put_tref(expr_start);
				}
				first_time = FALSE;
			}
			if (window_token != TK_COMMA)
				break;
			advancewindow();
		}
	}
	if (is_commarg)
	{
		if (window_token != TK_EOL)
		{
			stx_error(ERR_INDEXTRACHARS);
			return FALSE;
		}
		return TRUE;
	}
	if (window_token != TK_EOL && window_token != TK_SPACE)
	{
		stx_error(ERR_SPOREOL);
		return FALSE;
	}
	if (!linetail())
	{	tnxtarg(&x);
		dqloop(jmpchain,link,nxtjmp)
		{	ref1 = nxtjmp->jmptrip;
			ref1->operand[0] = x;
		}
示例#15
0
int f_order1( oprtype *a, opctype op)
{
	triple *oldchain, tmpchain, *r, *triptr;
	error_def(ERR_VAREXPECTED);
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	r = maketriple(op);
	switch (window_token)
	{
		case TK_IDENT:
			if (director_token != TK_LPAREN)
			{
				r->opcode = OC_FNLVNAME;
				r->operand[0] = put_str(window_ident.addr, window_ident.len);
				r->operand[1] = put_ilit(0);	/* FALSE - do not return aliased vars with no value */
				ins_triple(r);
				advancewindow();
				break;
			}
			if (!lvn(&(r->operand[0]), OC_SRCHINDX, r))
				return FALSE;
			ins_triple(r);
			break;
		case TK_CIRCUMFLEX:
			if (!gvn())
				return FALSE;
			r->opcode = OC_GVORDER;
			ins_triple(r);
			break;
		case TK_ATSIGN:
			if (TREF(shift_side_effects))
			{
				dqinit(&tmpchain, exorder);
				oldchain = setcurtchain(&tmpchain);
				if (!indirection(&(r->operand[0])))
				{
					setcurtchain(oldchain);
					return FALSE;
				}
				r->operand[1] = put_ilit((mint)indir_fnorder1);
				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));
			} else
			{
				if (!indirection(&(r->operand[0])))
					return FALSE;
				r->operand[1] = put_ilit((mint)indir_fnorder1);
				ins_triple(r);
			}
			r->opcode = OC_INDFUN;
			break;
		default:
			stx_error(ERR_VAREXPECTED);
			return FALSE;
	}
	*a = put_tref(r);
	return TRUE;
}
示例#16
0
文件: m_merge.c 项目: mihawk/fis-gtm
int m_merge(void)
{
	int		type;
	boolean_t	used_glvn_slot;
	mval		mv;
	opctype 	put_oc;
	oprtype 	mopr, control_slot;
	triple		*obp, *ref, *restart, *s1, *sub, tmpchain;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	used_glvn_slot = FALSE;
	sub = NULL;
	restart = newtriple(OC_RESTARTPC);	/* Here is where a restart should pick up */
	dqinit(&tmpchain, exorder);
	/* Left Hand Side of EQUAL sign */
	switch (TREF(window_token))
	{
		case TK_IDENT:
			if (!lvn(&mopr, OC_PUTINDX, 0))
				return FALSE;
			if (OC_PUTINDX == mopr.oprval.tref->opcode)
			{	/* we insert left hand side argument into tmpchain. */
				sub = mopr.oprval.tref;
				put_oc = OC_PUTINDX;
				dqdel(mopr.oprval.tref, exorder);
				dqins(tmpchain.exorder.bl, exorder, mopr.oprval.tref);
			}
			ref = maketriple(OC_MERGE_LVARG);
			ref->operand[0] = put_ilit(MARG1_LCL);
			ref->operand[1] = mopr;
			dqins(tmpchain.exorder.bl, exorder, ref);
			break;
		case TK_CIRCUMFLEX:
			s1 = (TREF(curtchain))->exorder.bl;
			if (!gvn())
				return FALSE;
			assert(OC_GVRECTARG != (TREF(curtchain))->opcode);	/* we count on gvn not having been shifted */
			for (sub = (TREF(curtchain))->exorder.bl; sub != s1; sub = sub->exorder.bl)
			{
				put_oc = sub->opcode;
				if (OC_GVNAME == put_oc || OC_GVNAKED == put_oc || OC_GVEXTNAM == put_oc)
					break;
			}
			assert((OC_GVNAME == put_oc) || (OC_GVNAKED == put_oc) || (OC_GVEXTNAM == put_oc));
			/* we insert left hand side argument into tmpchain. */
			dqdel(sub, exorder);
			dqins(tmpchain.exorder.bl ,exorder, sub);
			ref = maketriple(OC_MERGE_GVARG);
			ref->operand[0] = put_ilit(MARG1_GBL);
			dqins(tmpchain.exorder.bl, exorder, ref);
			break;
		case TK_ATSIGN:
			if (!indirection(&mopr))
				return FALSE;
			if (TK_EQUAL != TREF(window_token))
			{
				ref = newtriple(OC_COMMARG);
				ref->operand[0] = mopr;
				ref->operand[1] = put_ilit((mint) indir_merge);
				return TRUE;
			}
			type = MARG1_LCL | MARG1_GBL;
			memset(&mv, 0, SIZEOF(mval));	/* Initialize so unused fields don't cause object hash differences */
			MV_FORCE_MVAL(&mv, type);
			MV_FORCE_STRD(&mv);
			if (TREF(side_effect_handling))
			{	/* save and restore the variable lookup for true left-to-right evaluation */
				used_glvn_slot = TRUE;
				INSERT_INDSAVGLVN(control_slot, mopr, ANY_SLOT, 0);	/* 0 flag to defer global reference */
				ref = maketriple(OC_INDMERGE2);
				ref->operand[0] = control_slot;
			} else
			{	/* quick and dirty old way */
				ref = maketriple(OC_INDMERGE);
				ref->operand[0] = put_lit(&mv);
				ref->operand[1] = mopr;
			}
			/* we insert left hand side argument into tmpchain. */
			dqins(tmpchain.exorder.bl, exorder, ref);
			break;
		default:
			stx_error(ERR_VAREXPECTED);
			return FALSE;
	}
	if (TREF(window_token) != TK_EQUAL)
	{
		stx_error(ERR_EQUAL);
		return FALSE;
	}
	advancewindow();
	/* Right Hand Side of EQUAL sign */
	TREF(temp_subs) = FALSE;
	switch (TREF(window_token))
	{
		case TK_IDENT:
			if (!lvn(&mopr, OC_M_SRCHINDX, 0))
				return FALSE;
			ref = newtriple(OC_MERGE_LVARG);
			ref->operand[0] = put_ilit(MARG2_LCL);
			ref->operand[1] = mopr;
			break;
		case TK_CIRCUMFLEX:
			if (!gvn())
				return FALSE;
			ref = newtriple(OC_MERGE_GVARG);
			ref->operand[0] = put_ilit(MARG2_GBL);
			break;
		case TK_ATSIGN:
			TREF(temp_subs) = TRUE;
			if (!indirection(&mopr))
			{
				stx_error(ERR_VAREXPECTED);
				return FALSE;
			}
			type = MARG2_LCL | MARG2_GBL;
			memset(&mv, 0, SIZEOF(mval));	/* Initialize so unused fields don't cause object hash differences */
			MV_FORCE_MVAL(&mv, type);
			MV_FORCE_STRD(&mv);
			ref = maketriple(OC_INDMERGE);
			ref->operand[0] =  put_lit(&mv);
			ref->operand[1] = mopr;
			ins_triple(ref);
			break;
		default:
			stx_error(ERR_VAREXPECTED);
			return FALSE;
	}
	/*
	 * Make sure that during runtime right hand side argument is processed first.
	 * This is specially important if global naked variable is used .
	 */
	obp = (TREF(curtchain))->exorder.bl;
	dqadd(obp, &tmpchain, exorder);
	if (TREF(temp_subs) && TREF(side_effect_handling) && sub)
		create_temporaries(sub, put_oc);
	TREF(temp_subs) = FALSE;
	if (used_glvn_slot)
	{
		ref = newtriple(OC_GLVNPOP);
		ref->operand[0] = control_slot;
	}
	ref = newtriple(OC_MERGE);
	return TRUE;
}
示例#17
0
int exfunc(oprtype *a, boolean_t alias_target)
{
	triple		*calltrip, *calltrip_opr1_tref, *counttrip, *funret, *labelref, *masktrip;
	triple		*oldchain, *ref0, *routineref, tmpchain, *triptr;
#	if defined(USHBIN_SUPPORTED) || defined(VMS)
	triple		*tripsize;
#	endif

	assert(TK_DOLLAR == window_token);
	advancewindow();
	dqinit(&tmpchain, exorder);
	oldchain = setcurtchain(&tmpchain);
	calltrip = entryref(OC_EXFUN, OC_EXTEXFUN, INDIR_DUMMY, TRUE, TRUE, FALSE);
	setcurtchain(oldchain);
	if (!calltrip)
		return FALSE;
	if (OC_EXFUN == calltrip->opcode)
	{
		assert(MLAB_REF == calltrip->operand[0].oprclass);
#		if defined(USHBIN_SUPPORTED) || defined(VMS)
		ref0 = newtriple(OC_PARAMETER);
		ref0->operand[0] = put_tsiz();		/* Need size of following code gen triple here */
		calltrip->operand[1] = put_tref(ref0);
		tripsize = ref0->operand[0].oprval.tref;
		assert(OC_TRIPSIZE == tripsize->opcode);
#		else
		ref0 = calltrip;
#		endif
	} else
	{
		calltrip_opr1_tref = calltrip->operand[1].oprval.tref;
		if (OC_EXTEXFUN == calltrip->opcode)
		{
			assert(TRIP_REF == calltrip->operand[1].oprclass);
			if (OC_CDLIT == calltrip_opr1_tref->opcode)
				assert(CDLT_REF == calltrip_opr1_tref->operand[0].oprclass);
			else
			{
				assert(OC_LABADDR == calltrip_opr1_tref->opcode);
				assert(TRIP_REF == calltrip_opr1_tref->operand[1].oprclass);
				assert(OC_PARAMETER == calltrip_opr1_tref->operand[1].oprval.tref->opcode);
				assert(TRIP_REF == calltrip_opr1_tref->operand[1].oprval.tref->operand[0].oprclass);
				assert(OC_ILIT == calltrip_opr1_tref->operand[1].oprval.tref->operand[0].oprval.tref->opcode);
				assert(ILIT_REF
				       == calltrip_opr1_tref->operand[1].oprval.tref->operand[0].oprval.tref->operand[0].oprclass);
				if (0 != calltrip_opr1_tref->operand[1].oprval.tref->operand[0].oprval.tref->operand[0].oprval.ilit)
				{
					stx_error(ERR_ACTOFFSET);
					return FALSE;
				}
			}
		} else		/* $$ @dlabel [actuallist] */
		{
			assert(OC_COMMARG == calltrip->opcode);
			assert(TRIP_REF == calltrip->operand[1].oprclass);
			assert(OC_ILIT == calltrip_opr1_tref->opcode);
			assert(ILIT_REF == calltrip_opr1_tref->operand[0].oprclass);
			assert(INDIR_DUMMY == calltrip_opr1_tref->operand[0].oprval.ilit);
			assert(calltrip->exorder.fl == &tmpchain);
			routineref = maketriple(OC_CURRHD);
			labelref = maketriple(OC_LABADDR);
			ref0 = maketriple(OC_PARAMETER);
			dqins(calltrip->exorder.bl, exorder, routineref);
			dqins(calltrip->exorder.bl, exorder, labelref);
			dqins(calltrip->exorder.bl, exorder, ref0);
			labelref->operand[0] = calltrip->operand[0];
			labelref->operand[1] = put_tref(ref0);
			ref0->operand[0] = calltrip->operand[1];
			ref0->operand[0].oprval.tref->operand[0].oprval.ilit = 0;
			ref0->operand[1] = put_tref(routineref);
			calltrip->operand[0] = put_tref(routineref);
			calltrip->operand[1] = put_tref(labelref);
			calltrip->opcode = OC_EXTEXFUN;
		}
		ref0 = newtriple(OC_PARAMETER);
		ref0->operand[0] = calltrip->operand[1];
		calltrip->operand[1] = put_tref(ref0);
	}
	if (TK_LPAREN != window_token)
	{
		masktrip = newtriple(OC_PARAMETER);
		counttrip = newtriple(OC_PARAMETER);
		masktrip->operand[0] = put_ilit(0);
		counttrip->operand[0] = put_ilit(0);
		masktrip->operand[1] = put_tref(counttrip);
		ref0->operand[1] = put_tref(masktrip);
	} else
		if (!actuallist(&ref0->operand[1]))
			return FALSE;
	triptr = oldchain->exorder.bl;
	dqadd(triptr, &tmpchain, exorder);		/*this is a violation of info hiding*/
	if (OC_EXFUN == calltrip->opcode)
	{
		assert(MLAB_REF == calltrip->operand[0].oprclass);
		triptr = newtriple(OC_JMP);
		triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname);
		calltrip->operand[0].oprclass = ILIT_REF;	/* dummy placeholder */
#		if defined(USHBIN_SUPPORTED) || defined(VMS)
		tripsize->operand[0].oprval.tsize->ct = triptr;
#		endif
	}
	/* If target is an alias, use special container-expecting routine OC_EXFUNRETALS, else regular OC_EXFUNRET */
	funret = newtriple((alias_target ? OC_EXFUNRETALS : OC_EXFUNRET));
	funret->operand[0] = *a = put_tref(calltrip);
	return TRUE;
}
示例#18
0
文件: m_do.c 项目: h4ck3rm1k3/fis-gtm
int m_do(void)
{
	triple		tmpchain, *oldchain, *obp, *ref0, *tripsize,
			*triptr, *ref1, *calltrip, *routineref, *labelref;
	oprtype		*cr;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	if ((TK_SPACE == window_token) || (TK_EOL == window_token))
	{
		if (!run_time)	/* DO SP SP is a noop at run time */
		{
			calltrip = newtriple(OC_CALLSP);
			calltrip->operand[0] = put_mnxl();
			calltrip->operand[1] = put_ocnt();
		}
		return TRUE;
	} else if (TK_AMPERSAND == window_token)
	{
		if (!extern_func(0))
			return FALSE;
		else
			return TRUE;
	}
	dqinit(&tmpchain, exorder);
	oldchain = setcurtchain(&tmpchain);
	calltrip = entryref(OC_CALL, OC_EXTCALL, (mint)indir_do, TRUE, FALSE, FALSE);
	setcurtchain(oldchain);
	if (!calltrip)
		return FALSE;
	if (TK_LPAREN == window_token)
	{
		if (OC_CALL == calltrip->opcode)
		{
			assert(MLAB_REF == calltrip->operand[0].oprclass);
			calltrip->opcode = OC_EXCAL;
			ref0 = newtriple(OC_PARAMETER);
			calltrip->operand[1] = put_tref(ref0);
			ref0->operand[0] = put_tsiz();	/* parm to hold size of jump codegen */
			tripsize = ref0->operand[0].oprval.tref;
			assert(OC_TRIPSIZE == tripsize->opcode);
		} else
		{
			if (OC_EXTCALL == calltrip->opcode)
			{
				assert(TRIP_REF == calltrip->operand[1].oprclass);
				if (OC_CDLIT == calltrip->operand[1].oprval.tref->opcode)
					assert(CDLT_REF == calltrip->operand[1].oprval.tref->operand[0].oprclass);
				else
				{
					assert(OC_LABADDR == calltrip->operand[1].oprval.tref->opcode);
					assert(TRIP_REF == calltrip->operand[1].oprval.tref->operand[1].oprclass);
					assert(OC_PARAMETER == calltrip->operand[1].oprval.tref->operand[1].oprval.tref->opcode);
					assert(TRIP_REF ==
						calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprclass);
					assert(OC_ILIT == calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
						operand[0].oprval.tref->opcode);
					assert(ILIT_REF == calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
						operand[0].oprval.tref->operand[0].oprclass);
					if (0 != calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
						operand[0].oprval.tref->operand[0].oprval.ilit)
					{
						stx_error(ERR_ACTOFFSET);
						return FALSE;
					}
				}
			} else		/* DO _ @dlabel actuallist */
			{
				assert(OC_COMMARG == calltrip->opcode);
				assert(TRIP_REF == calltrip->operand[1].oprclass);
				assert(OC_ILIT == calltrip->operand[1].oprval.tref->opcode);
				assert(ILIT_REF == calltrip->operand[1].oprval.tref->operand[0].oprclass);
				assert((mint)indir_do == calltrip->operand[1].oprval.tref->operand[0].oprval.ilit);
				assert(calltrip->exorder.fl == &tmpchain);
				routineref = maketriple(OC_CURRHD);
				labelref = maketriple(OC_LABADDR);
				ref0 = maketriple(OC_PARAMETER);
				dqins(calltrip->exorder.bl, exorder, routineref);
				dqins(calltrip->exorder.bl, exorder, labelref);
				dqins(calltrip->exorder.bl, exorder, ref0);
				labelref->operand[0] = calltrip->operand[0];
				labelref->operand[1] = put_tref(ref0);
				ref0->operand[0] = calltrip->operand[1];
				ref0->operand[0].oprval.tref->operand[0].oprval.ilit = 0;
				ref0->operand[1] = put_tref(routineref);
				calltrip->operand[0] = put_tref(routineref);
				calltrip->operand[1] = put_tref(labelref);
			}
			calltrip->opcode = OC_EXTEXCAL;
			ref0 = newtriple(OC_PARAMETER);
			ref0->operand[0] = calltrip->operand[1];
			calltrip->operand[1] = put_tref(ref0);
		}
		if (!actuallist(&ref0->operand[1]))
			return FALSE;
	} else if (OC_CALL == calltrip->opcode)
	{
		calltrip->operand[1] = put_ocnt();
		if (TREF(for_stack_ptr) != TADR(for_stack))
		{
			if (TAREF1(for_temps, (TREF(for_stack_ptr) - TADR(for_stack))))
				calltrip->opcode = OC_FORLCLDO;
		}
	}
	if (TK_COLON == window_token)
	{
		advancewindow();
		cr = (oprtype *)mcalloc(SIZEOF(oprtype));
		if (!bool_expr((bool) FALSE, cr))
			return FALSE;
		if (TREF(expr_start) != TREF(expr_start_orig))
		{
			triptr = newtriple(OC_GVRECTARG);
			triptr->operand[0] = put_tref(TREF(expr_start));
		}
		obp = oldchain->exorder.bl;
		dqadd(obp, &tmpchain, exorder);   /*this is a violation of info hiding*/
		if (OC_EXCAL == calltrip->opcode)
		{
			triptr = newtriple(OC_JMP);
			triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname);
			calltrip->operand[0].oprclass = ILIT_REF;	/* dummy placeholder */
			tripsize->operand[0].oprval.tsize->ct = triptr;
		}
		if (TREF(expr_start) != TREF(expr_start_orig))
		{
			ref0 = newtriple(OC_JMP);
			ref1 = newtriple(OC_GVRECTARG);
			ref1->operand[0] = put_tref(TREF(expr_start));
			*cr = put_tjmp(ref1);
			tnxtarg(&ref0->operand[0]);
		} else
			tnxtarg(cr);
	} else
	{
		obp = oldchain->exorder.bl;
		dqadd(obp, &tmpchain, exorder);   /*this is a violation of info hiding*/
		if (OC_EXCAL == calltrip->opcode)
		{
			triptr = newtriple(OC_JMP);
			triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname);
			calltrip->operand[0].oprclass = ILIT_REF;	/* dummy placeholder */
			tripsize->operand[0].oprval.tsize->ct = triptr;
		}
	}
	return TRUE;
}
示例#19
0
int f_get(oprtype *a, opctype op)
{
	triple		tmpchain, *oldchain, *r, *triptr;
	triple		*jmp_to_get, *ret_get_val;
	oprtype		result, *result_ptr;
	error_def(ERR_VAREXPECTED);


	result_ptr = (oprtype *)mcalloc(sizeof(oprtype));
	result = put_indr(result_ptr);

	jmp_to_get = maketriple(op);
	ret_get_val = maketriple(op);

	r = maketriple(op);

	switch (window_token)
	{
	case TK_IDENT:
		if (!lvn(&r->operand[0], OC_SRCHINDX, 0))
			return FALSE;

		if (window_token != TK_COMMA)
		{
			ins_triple(r);
			*a = put_tref(r);
			return TRUE;
		}

		r->opcode = OC_FNGET2;
		r->operand[1] = result;
		break;

	case TK_CIRCUMFLEX:

		r->opcode = OC_FNGVGET1;

		if (!gvn())
			return FALSE;

		ins_triple(r);

		jmp_to_get->opcode = OC_JMPNEQ;
		jmp_to_get->operand[0] = put_tjmp(ret_get_val);

		ins_triple(jmp_to_get);

		ret_get_val->opcode = OC_FNGVGET2;
		ret_get_val->operand[0] = put_tref(r);
		ret_get_val->operand[1] = result;

		if (window_token != TK_COMMA)
			*result_ptr = put_str(0,0);
		else
		{
			advancewindow();
			if (!expr(result_ptr))
				return FALSE;
		}

		ins_triple(ret_get_val);
		*a = put_tref(ret_get_val);

		return TRUE;
		break;

	case TK_ATSIGN:
		r->opcode = OC_INDGET;

		if (shift_gvrefs)
		{
			dqinit(&tmpchain, exorder);
			oldchain = setcurtchain(&tmpchain);
			if (!indirection(&r->operand[0]))
			{
				setcurtchain(oldchain);
				return FALSE;
			}

			r->operand[1] = result;
			if (window_token == TK_COMMA)
			{
				advancewindow();
				if (!expr(result_ptr))
					return FALSE;
			}
			else
				*result_ptr = put_str(0, 0);
			ins_triple(r);

			newtriple(OC_GVSAVTARG);
			setcurtchain(oldchain);
			dqadd(expr_start, &tmpchain, exorder);
			expr_start = tmpchain.exorder.bl;
			triptr = newtriple(OC_GVRECTARG);
			triptr->operand[0] = put_tref(expr_start);
			*a = put_tref(r);
			return TRUE;
		}

		if (!indirection(&r->operand[0]))
			return FALSE;

		r->operand[1] = result;
		break;

	default:
		stx_error(ERR_VAREXPECTED);
		return FALSE;
	}

	if (window_token == TK_COMMA)
	{
		advancewindow();
		if (!expr(result_ptr))
			return FALSE;
	}
	else
		*result_ptr = put_str(0, 0);

	ins_triple(r);
	*a = put_tref(r);

	return TRUE;
}
示例#20
0
文件: f_get.c 项目: CeperaCPP/fis-gtm
int f_get(oprtype *a, opctype op)
{
	triple		*oldchain, *r, tmpchain, *triptr;
	oprtype		result, *result_ptr;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	result_ptr = (oprtype *)mcalloc(SIZEOF(oprtype));
	result = put_indr(result_ptr);
	r = maketriple(op);
	switch (TREF(window_token))
	{
	case TK_IDENT:
		if (!lvn(&r->operand[0], OC_SRCHINDX, 0))
			return FALSE;
		if (TK_COMMA != TREF(window_token))
		{
			ins_triple(r);
			*a = put_tref(r);
			return TRUE;
		}
		r->opcode = OC_FNGET2;
		r->operand[1] = result;
		break;
	case TK_CIRCUMFLEX:
		if (!gvn())
			return FALSE;
		if (TK_COMMA == TREF(window_token))
		{	/* 2-argument $GET with global-variable as first argument. In this case generate the following
			 * sequence of opcodes. OC_FNGVGET1, opcodes-to-evaluate-second-argument-expression, OC_FNGVGET2
			 */
			r->opcode = OC_FNGVGET1;
			ins_triple(r);
			triptr = r;
			/* Prepare triple for OC_FNGVGET2 */
			r = maketriple(op);
			r->opcode = OC_FNGVGET2;
			r->operand[0] = put_tref(triptr);
			r->operand[1] = result;
		} else
		{
			r->opcode = OC_FNGVGET;
			r->operand[0] = result;
		}
		break;
	case TK_ATSIGN:
		r->opcode = OC_INDGET;
		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;
			}
			r->operand[1] = result;
			if (TK_COMMA == TREF(window_token))
			{
				advancewindow();
				if (EXPR_FAIL == expr(result_ptr, MUMPS_EXPR))
					return FALSE;
			} else
				*result_ptr = put_str(0, 0);
			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;
		r->operand[1] = result;
		break;
	default:
		stx_error(ERR_VAREXPECTED);
		return FALSE;
	}
	if (TK_COMMA == TREF(window_token))
	{
		advancewindow();
		if (EXPR_FAIL == expr(result_ptr, MUMPS_EXPR))
			return FALSE;
	} else
		*result_ptr = put_str(0, 0);
	ins_triple(r);
	*a = put_tref(r);
	return TRUE;
}
示例#21
0
void bx_boolop(triple *t, boolean_t jmp_type_one, boolean_t jmp_to_next, boolean_t sense, oprtype *addr)
{
	boolean_t	expr_fini;
	oprtype		*adj_addr, *i, *p;
	tbp		*tripbp;
	triple		*ref0, *ref1, *ref2, *t0, *t1;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	assert(((1 & sense) == sense) && ((1 & jmp_to_next) == jmp_to_next) && ((1 & jmp_type_one) == jmp_type_one));
	assert((TRIP_REF == t->operand[0].oprclass) && (TRIP_REF == t->operand[1].oprclass));
	if (jmp_to_next)
	{
		p = (oprtype *)mcalloc(SIZEOF(oprtype));
		*p = put_tjmp(t);
	} else
		p = addr;
	if (GTM_BOOL == TREF(gtm_fullbool) || !TREF(saw_side_effect))
	{	/* nice simple short circuit */
		assert(NULL == TREF(boolchain_ptr));
		bx_tail(t->operand[0].oprval.tref, jmp_type_one, p);
		bx_tail(t->operand[1].oprval.tref, sense, addr);
		t->opcode = OC_NOOP;
		t->operand[0].oprclass = t->operand[1].oprclass = NOCLASS;
		return;
	}
	/* got a side effect and don't want them short circuited */
	/* This code violates info hiding big-time and relies on the original technique of setting up a jump ladder
	 * then it changes the jumps into stotemps and creates a new ladder using the saved evaluations
	 * for the relocated jumps to use for controlling conditional transfers, When the stotemps reference mvals,
	 * they are optimized away when possible. The most interesting part is getting the addresses for the new jump
	 * operands (targets) - see comment below. In theory we could turn this technique on and off around each side effect,
	 * but that's even more complicated, requiring additional instructions, and we don't predict the typical boolean
	 * expression has enough subexpressions to justify the extra trouble, although the potential pay-back would be to
	 * avoid unnecessary global references - again, not expecting that many in a typical boolean expresion.
	 */
	assert(TREF(shift_side_effects));
	if (expr_fini = (NULL == TREF(boolchain_ptr)))				/* NOTE assignment */
	{									/* initialize work on boolean section of the AST */
		TREF(boolchain_ptr) = &(TREF(boolchain));
		dqinit(TREF(boolchain_ptr), exorder);
		t0 = t->exorder.fl;
		if (NULL == TREF(bool_targ_ptr))
		{								/* first time - set up anchor */
			TREF(bool_targ_ptr) = &(TREF(bool_targ_anchor));	/* mcalloc won't persist over multiple complies */
			dqinit(TREF(bool_targ_ptr), que);
		} else								/* queue should be empty */
			assert((TREF(bool_targ_ptr) == (TREF(bool_targ_ptr))->que.fl)
				&& (TREF(bool_targ_ptr) == (TREF(bool_targ_ptr))->que.bl));
		/* ex_tail wraps bools that produce a value with OC_BOOLINIT (clr) and OC_BOOLFINI (set) */
		assert((OC_BOOLFINI != t0->opcode)
			|| ((OC_COMVAL == t0->exorder.fl->opcode) && (TRIP_REF == t0->operand[0].oprclass)));
	}
	for (i = t->operand; i < ARRAYTOP(t->operand); i++)
	{
		assert(NULL != TREF(boolchain_ptr));
		t1 = i->oprval.tref;
		if (&(t->operand[0]) == i)
			bx_tail(t1, jmp_type_one, p);				/* do normal transform */
		else
		{	/* operand[1] */
			bx_tail(t1, sense, addr);				/* do normal transform */
			if (!expr_fini)
				break;						/* only need to relocate last operand[1] */
		}
		if (OC_NOOP == t1->opcode)
		{	/* the technique of sprinkling noops means fishing around for the actual instruction */
			do
			{
				t1 = t1->exorder.bl;
				assert(TREF(curtchain) != t1->exorder.bl);
			} while (OC_NOOP == t1->opcode);
			if ((oc_tab[t1->opcode].octype & OCT_JUMP) && (OC_JMPTSET != t1->opcode) && (OC_JMPTCLR != t1->opcode))
				t1 = t1->exorder.bl;
			if (OC_NOOP == t1->opcode)
			{
				for (t1 = i->oprval.tref; OC_NOOP == t1->opcode; t1 = t1->exorder.fl)
					assert(TREF(curtchain) != t1->exorder.fl);
			}
		}
		assert(OC_NOOP != t1->opcode);
		assert((oc_tab[t1->exorder.fl->opcode].octype & OCT_JUMP)
			||(OC_JMPTSET != t1->exorder.fl->opcode) || (OC_JMPTCLR != t1->exorder.fl->opcode));
		ref0 = maketriple(t1->opcode);					/* copy operation for place in new ladder */
		ref1 = (TREF(boolchain_ptr))->exorder.bl;			/* common setup for above op insert */
		switch (t1->opcode)
		{								/* time to subvert original jump ladder entry */
			case OC_COBOOL:
				/* insert COBOOL and copy of following JMP in boolchain; overlay them with STOTEMP and NOOP  */
				assert(TRIP_REF == t1->operand[0].oprclass);
				dqins(ref1, exorder, ref0);
				if (oc_tab[t1->operand[0].oprval.tref->opcode].octype & OCT_MVAL)
				{						/* do we need a STOTEMP? */
					switch (t1->operand[0].oprval.tref->opcode)
					{
						case OC_INDGLVN:		/* indirect actions not happy without STOTEMP */
						case OC_INDNAME:
						case OC_VAR:			/* variable could change so must save it */
							t1->opcode = OC_STOTEMP;
							ref0->operand[0] = put_tref(t1);/* new COBOOL points to this OC_STOTEMP */
							break;
						default:			/* else no temporary if it's mval */
							ref0->operand[0] = put_tref(t1->operand[0].oprval.tref);
							t1->opcode = OC_NOOP;
							t1->operand[0].oprclass = NOCLASS;
					}
				} else
				{						/* make it an mval instead of COBOOL now */
					t1->opcode = OC_COMVAL;
					ref0->operand[0] = put_tref(t1);	/* new COBOOL points to this OC_COMVAL  */
				}
				t1 = t1->exorder.fl;
				ref0 = maketriple(t1->opcode);			/* create new jmp on result of coerce */
				ref0->operand[0] = t1->operand[0];
				t1->opcode = OC_NOOP;				/* wipe out original jmp */
				t1->operand[0].oprclass = NOCLASS;
				break;
			case OC_CONTAIN:
			case OC_EQU:
			case OC_FOLLOW:
			case OC_NUMCMP:
			case OC_PATTERN:
			case OC_SORTS_AFTER:
				/* insert copies of orig OC and following JMP in boolchain & overly originals with STOTEMPs */
				assert(TRIP_REF == t1->operand[0].oprclass);
				assert(TRIP_REF == t1->operand[1].oprclass);
				dqins(ref1, exorder, ref0);
				if (OC_VAR == t1->operand[0].oprval.tref->opcode)
				{						/* VAR could change so must save it */
					t1->opcode = OC_STOTEMP;		/* overlay the original op with a STOTEMP */
					ref0->operand[0] = put_tref(t1);	/* new op points to thi STOTEMP */
				} else
				{						/* no need for a temporary unless it's a VAR */
					ref0->operand[0] = put_tref(t1->operand[0].oprval.tref);
					t1->opcode = OC_NOOP;
				}
				ref1 = t1;
				t1 = t1->exorder.fl;
				ref2 = maketriple(t1->opcode);			/* copy jmp */
				ref2->operand[0] = t1->operand[0];
				if (OC_VAR == ref1->operand[1].oprval.tref->opcode)
				{						/* VAR could change so must save it */
					ref0->operand[1] = put_tref(t1);	/* new op points to STOTEMP overlaying the jmp  */
					t1->operand[0] = ref1->operand[1];
					t1->opcode = OC_STOTEMP;		/* overlay jmp with 2nd STOTEMP */
				} else
				{						/* no need for a temporary unless it's a VAR */
					ref0->operand[1] = put_tref(ref1->operand[1].oprval.tref);
					t1->opcode = OC_NOOP;
					t1->operand[0].oprclass = NOCLASS;
				}
				if (OC_NOOP == ref1->opcode)			/* does op[0] need cleanup? */
					ref1->operand[0].oprclass = ref1->operand[1].oprclass = NOCLASS;
				ref0 = ref2;
				break;
			case OC_JMPTSET:
			case OC_JMPTCLR:
										/* move copy of jmp to boolchain and NOOP it */
				ref0->operand[0] = t1->operand[0];		/* new jmpt gets old target */
				ref2 = maketriple(OC_NOOP);			/* insert a NOOP in new chain inplace of COBOOL */
				dqins(ref1, exorder, ref2);
				t1->opcode = OC_NOOP;				/* wipe out original jmp */
				t1->operand[0].oprclass = NOCLASS;
				break;
			default:
				assertpro(FALSE);
		}
		assert((OC_STOTEMP == t1->opcode) || (OC_NOOP == t1->opcode) || (OC_COMVAL == t1->opcode));
		assert(oc_tab[ref0->opcode].octype & OCT_JUMP);
		ref1 = (TREF(boolchain_ptr))->exorder.bl;
		dqins(ref1, exorder, ref0);					/* common insert for new jmp */
	}
	assert(oc_tab[t->opcode].octype & OCT_BOOL);
	t->opcode = OC_NOOP;							/* wipe out the original boolean op */
	t->operand[0].oprclass = t->operand[1].oprclass = NOCLASS;
	tripbp = &t->jmplist;							/* borrow jmplist to track jmp targets */
	assert(NULL == tripbp->bpt);
	assert((tripbp == tripbp->que.fl) && (tripbp == tripbp->que.bl));
	tripbp->bpt = jmp_to_next ? (TREF(boolchain_ptr))->exorder.bl : ref0;	/* point op triple at op[1] position or op[0] */
	dqins(TREF(bool_targ_ptr), que, tripbp);				/* queue jmplist for clean-up */
	if (!expr_fini)
		return;
	/* time to deal with new jump ladder */
	assert(NULL != TREF(boolchain_ptr));
	assert(NULL != TREF(bool_targ_ptr));
	assert(TREF(bool_targ_ptr) != (TREF(bool_targ_ptr))->que.fl);
	assert(t0->exorder.bl == t);
	assert(t0 == t->exorder.fl);
	dqadd(t, TREF(boolchain_ptr), exorder);					/* insert the new jump ladder */
	ref0 = (TREF(boolchain_ptr))->exorder.bl->exorder.fl;
	t0 = t->exorder.fl;
	if (ref0 == TREF(curtchain))
	{									/* add a safe target */
		newtriple(OC_NOOP);
		ref0 = (TREF(curtchain))->exorder.bl;
	}
	assert((OC_COBOOL == t0->opcode) ||(OC_JMPTSET != t0->opcode) || (OC_JMPTCLR != t0->opcode)) ;
	t0 = t0->exorder.fl;
	assert(oc_tab[t0->opcode].octype & OCT_JUMP);
	for (; (t0 != ref0) && oc_tab[t0->opcode].octype & OCT_JUMP; t0 = t0->exorder.fl)
	{									/* process replacement jmps */
		adj_addr = &t0->operand[0];
		assert(INDR_REF == adj_addr->oprclass);
		if (NULL != (t1 = (adj_addr = adj_addr->oprval.indr)->oprval.tref))
		{								/*  need to adjust target; NOTE assignments above */
			if (OC_BOOLFINI != t1->opcode)
			{							/* not past the end of the new chain */
				assert(TJMP_REF == adj_addr->oprclass);
				if ((t == t1) || (t1 == ref0))
					ref1 = ref0;				/* adjust to end of boolean expression */
				else
				{						/* old target should have jmplist entry */
					/* from the jmp jmplisted in the old target we move past the next
					 * test (or NOOP) and jmp which correspond to the old target and pick
					 * the subsequent test (or NOOP) and jmp which correspond to those that originally followed
					 * the logic after the old target and are therefore the appropriate new target for this jmp
					 */
					assert(OC_NOOP == t1->opcode);
					assert(&(t1->jmplist) != t1->jmplist.que.fl);
					assert(NULL != t1->jmplist.bpt);
					assert(oc_tab[t1->jmplist.bpt->opcode].octype & OCT_JUMP);
					ref1 = t1->jmplist.bpt->exorder.fl;
					assert((oc_tab[ref1->opcode].octype & OCT_BOOL) || (OC_NOOP == ref1->opcode));
					assert(oc_tab[ref1->exorder.fl->opcode].octype & OCT_JUMP);
					ref1 = ref1->exorder.fl->exorder.fl;
					assert((oc_tab[ref1->opcode].octype & OCT_BOOL) || (OC_BOOLFINI == ref1->opcode)
						|| ((OC_NOOP == ref1->opcode) && ((OC_JMPTCLR == ref1->exorder.fl->opcode)
						|| (OC_JMPTSET == ref1->exorder.fl->opcode)
						|| (TREF(curtchain) == ref1->exorder.fl))));
				}
				t0->operand[0] = put_tjmp(ref1);		/* no indrection simplifies later interations */
			}
		}
		t0 = t0->exorder.fl;
		if ((OC_BOOLFINI == t0->opcode) || (TREF(curtchain) == t0->exorder.fl))
			break;
		assert((oc_tab[t0->opcode].octype & OCT_BOOL)
			|| (OC_JMPTSET == t0->exorder.fl->opcode) || (OC_JMPTCLR == t0->exorder.fl->opcode));
	}
	dqloop(TREF(bool_targ_ptr), que, tripbp)				/* clean up borrowed jmplist entries */
	{
		dqdel(tripbp, que);
		tripbp->bpt = NULL;
	}
示例#22
0
文件: m_do.c 项目: mihawk/fis-gtm
int m_do(void)
{
	int		opcd;
	oprtype		*cr;
	triple		*calltrip, *labelref, *obp, *oldchain, *ref0, *ref1, *routineref, tmpchain, *triptr;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	if ((TK_EOL == TREF(window_token)) || (TK_SPACE == TREF(window_token)))
	{
		if (!run_time)	/* DO SP SP is a noop at run time */
		{
			calltrip = newtriple(OC_CALLSP);
			calltrip->operand[0] = put_mnxl();
		}
		return TRUE;
	} else if (TK_AMPERSAND == TREF(window_token))
	{
		if (!extern_func(0))
			return FALSE;
		else
			return TRUE;
	}
	dqinit(&tmpchain, exorder);
	oldchain = setcurtchain(&tmpchain);
	calltrip = entryref(OC_CALL, OC_EXTCALL, (mint)indir_do, TRUE, FALSE, FALSE);
	setcurtchain(oldchain);
	if (!calltrip)
		return FALSE;
	if (TK_LPAREN == TREF(window_token))
	{
		if (OC_CALL == calltrip->opcode)
		{
			assert(MLAB_REF == calltrip->operand[0].oprclass);
			calltrip->opcode = OC_EXCAL;
			ref0 = calltrip;
		} else
		{
			if (OC_EXTCALL == calltrip->opcode)
			{
				assert(TRIP_REF == calltrip->operand[1].oprclass);
				if (OC_CDLIT == calltrip->operand[1].oprval.tref->opcode)
					assert(CDLT_REF == calltrip->operand[1].oprval.tref->operand[0].oprclass);
				else
				{
					assert(OC_LABADDR == calltrip->operand[1].oprval.tref->opcode);
					assert(TRIP_REF == calltrip->operand[1].oprval.tref->operand[1].oprclass);
					assert(OC_PARAMETER == calltrip->operand[1].oprval.tref->operand[1].oprval.tref->opcode);
					assert(TRIP_REF ==
						calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprclass);
					DEBUG_ONLY(opcd = calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
						   operand[0].oprval.tref->opcode);
					assert((OC_ILIT == opcd) || (OC_COMINT == opcd));
					DEBUG_ONLY(opcd = calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
						   operand[0].oprval.tref->operand[0].oprclass);
					assert((ILIT_REF == opcd) || (TRIP_REF == opcd));
					/* The opcd references above added to allow an invalid syntax using indirect values for
					 * offsets while specifying a parm list to get through the above asserts (invalid syntax
					 * should not trip asserts) but it leads to the conclusion that the below test may not be
					 * robust enough since it is looking at a literal integer value when there is none so have
					 * added further checks mirroring the first checks done in the two most recent asserts to
					 * make the check more robust. [Example bad code: Do @lbl+@n^artn(arg)]
					 */
					if ((0 != calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
					     operand[0].oprval.tref->operand[0].oprval.ilit)
					    || (OC_ILIT != calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
						operand[0].oprval.tref->opcode)
					    || (ILIT_REF != calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
						operand[0].oprval.tref->operand[0].oprclass))
					{
						stx_error (ERR_ACTOFFSET);
						return FALSE;
					}
				}
			} else
			{	/* DO _ @dlabel actuallist */
				assert(OC_COMMARG == calltrip->opcode);
				assert(TRIP_REF == calltrip->operand[1].oprclass);
				assert(OC_ILIT == calltrip->operand[1].oprval.tref->opcode);
				assert(ILIT_REF == calltrip->operand[1].oprval.tref->operand[0].oprclass);
				assert((mint)indir_do == calltrip->operand[1].oprval.tref->operand[0].oprval.ilit);
				assert(calltrip->exorder.fl == &tmpchain);
				routineref = maketriple(OC_CURRHD);
				labelref = maketriple(OC_LABADDR);
				ref0 = maketriple(OC_PARAMETER);
				dqins(calltrip->exorder.bl, exorder, routineref);
				dqins(calltrip->exorder.bl, exorder, labelref);
				dqins(calltrip->exorder.bl, exorder, ref0);
				labelref->operand[0] = calltrip->operand[0];
				labelref->operand[1] = put_tref (ref0);
				ref0->operand[0] = calltrip->operand[1];
				ref0->operand[0].oprval.tref->operand[0].oprval.ilit = 0;
				ref0->operand[1] = put_tref (routineref);
				calltrip->operand[0] = put_tref(routineref);
				calltrip->operand[1] = put_tref(labelref);
			}
			calltrip->opcode = OC_EXTEXCAL;
			ref0 = newtriple(OC_PARAMETER);
			ref0->operand[0] = calltrip->operand[1];
			calltrip->operand[1] = put_tref(ref0);
		}
		if (!actuallist(&ref0->operand[1]))
			return FALSE;
	} else if (OC_CALL == calltrip->opcode)
	{
		if (TREF(for_stack_ptr) != (oprtype **)TADR(for_stack))
		{
			if (TAREF1(for_temps, (TREF(for_stack_ptr) - (oprtype **)TADR(for_stack))))
				calltrip->opcode = OC_FORLCLDO;
		}
	}
	if (TK_COLON == TREF(window_token))
	{
		advancewindow();
		cr = (oprtype *)mcalloc(SIZEOF(oprtype));
		if (!bool_expr(FALSE, cr))
			return FALSE;
		if ((TREF(expr_start) != TREF(expr_start_orig)) && (OC_NOOP != (TREF(expr_start))->opcode))
		{
			triptr = newtriple(OC_GVRECTARG);
			triptr->operand[0] = put_tref(TREF(expr_start));
		}
		obp = oldchain->exorder.bl;
		dqadd(obp, &tmpchain, exorder);   /*this is a violation of info hiding*/
		if (calltrip->opcode == OC_EXCAL)
		{
			triptr = newtriple(OC_JMP);
			triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname);
			calltrip->operand[0].oprclass = ILIT_REF;	/* dummy placeholder */
		}
		if ((TREF(expr_start) != TREF(expr_start_orig)) && (OC_NOOP != (TREF(expr_start))->opcode))
		{
			ref0 = newtriple(OC_JMP);
			ref1 = newtriple(OC_GVRECTARG);
			ref1->operand[0] = put_tref(TREF(expr_start));
			*cr = put_tjmp(ref1);
			tnxtarg(&ref0->operand[0]);
		} else
			tnxtarg(cr);
	} else
	{
		obp = oldchain->exorder.bl;
		dqadd(obp, &tmpchain, exorder);   /*this is a violation of info hiding*/
		if (OC_EXCAL == calltrip->opcode)
		{
			triptr = newtriple(OC_JMP);
			triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname);
			calltrip->operand[0].oprclass = ILIT_REF;	/* dummy placeholder */
		}
	}
	return TRUE;
}
示例#23
0
int f_incr(oprtype *a, opctype op)
{
	boolean_t	ok;
	oprtype		*increment;
	triple		incrchain, *oldchain, *r, *savptr, targchain, tmpexpr, *triptr;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	r = maketriple(op);
	/* may need to evaluate the increment (2nd arg) early and use result later: prepare to juggle triple chains */
	dqinit(&targchain, exorder);	/* a place for the operation and the target */
	dqinit(&tmpexpr, exorder);	/* a place to juggle the shifted chain in case it's active */
	triptr = TREF(expr_start);
	savptr = TREF(expr_start_orig);	/* but make sure expr_start_orig == expr_start since this is a new chain */
	TREF(expr_start_orig) = TREF(expr_start) = &tmpexpr;
	oldchain = setcurtchain(&targchain);	/* save the result of the first argument 'cause it evaluates 2nd */
	switch (TREF(window_token))
	{
	case TK_IDENT:
		/* $INCREMENT() performs an implicit $GET() on a first argument lvn so we use OC_PUTINDX because
		 * we know only at runtime whether to signal an UNDEF error (depending on whether we have
		 * VIEW "NOUNDEF" or "UNDEF" state; op_putindx creates the local variable unconditionally, even if
		 * we have "UNDEF" state, in which case any error in op_fnincr causes an op_kill of that local variable
		 */
		ok = (lvn(&(r->operand[0]), OC_PUTINDX, 0));
		break;
	case TK_CIRCUMFLEX:
		ok = gvn();
		r->opcode = OC_GVINCR;
		r->operand[0] = put_ilit(0);	/* dummy fill since emit_code does not like empty operand[0] */
		break;
	case TK_ATSIGN:
		ok = indirection(&r->operand[0]);
		r->opcode = OC_INDINCR;
		break;
	default:
		ok = FALSE;
		break;
	}
	if (!ok)
	{
		setcurtchain(oldchain);
		return FALSE;
	}
	TREF(expr_start) = triptr;				/* restore original shift chain */
	TREF(expr_start_orig) = savptr;
	increment = &r->operand[1];
	if (TK_COMMA != TREF(window_token))
		*increment = put_ilit(1);	/* default optional increment to 1 */
	else
	{
		dqinit(&incrchain, exorder);	/* a place for the increment */
		setcurtchain(&incrchain);	/* increment expr must evaluate before the glvn in $INCR(glvn,expr) */
		advancewindow();
		if (EXPR_FAIL == expr(increment, MUMPS_NUM))
		{
			setcurtchain(oldchain);
			return FALSE;
		}
		dqadd(&targchain, &incrchain, exorder);	/* dir before targ - this is a violation of info hiding */
		setcurtchain(&targchain);
	}
	coerce(increment, OCT_MVAL);
	ins_triple(r);
	if (&tmpexpr != tmpexpr.exorder.bl)
	{	/* one or more OC_GVNAME may have shifted so add to the end of the shift chain */
		assert(TREF(shift_side_effects));
		dqadd(TREF(expr_start), &tmpexpr, exorder);	/* this is a violation of info hiding */
		TREF(expr_start) = tmpexpr.exorder.bl;
		assert(OC_GVSAVTARG == (TREF(expr_start))->opcode);
		triptr = newtriple(OC_GVRECTARG);	/* restore the result of the last gvn to preserve $referece (the naked) */
		triptr->operand[0] = put_tref(TREF(expr_start));
	}
	if (!TREF(shift_side_effects) || (GTM_BOOL != TREF(gtm_fullbool)) || (OC_INDINCR != r->opcode))
	{	/* put it on the end of the main chain as there's no reason to play more with the ordering */
		setcurtchain(oldchain);
		triptr = (TREF(curtchain))->exorder.bl;
		dqadd(triptr, &targchain, exorder);	/* this is a violation of info hiding */
	} else	/* need full side effects or indirect 1st argument so put everything on the shift chain */
	{	/* add the chain after "expr_start" which may be much before "curtchain" */
		newtriple(OC_GVSAVTARG);
		setcurtchain(oldchain);
		assert(NULL != TREF(expr_start));
		dqadd(TREF(expr_start), &targchain, exorder);	/* this is a violation of info hiding */
		TREF(expr_start) = targchain.exorder.bl;
		triptr = newtriple(OC_GVRECTARG);
		triptr->operand[0] = put_tref(TREF(expr_start));
	}
	/* $increment() args need to avoid side effect processing but that's handled in expritem so eval_expr gets $i()'s SE flag */
	*a = put_tref(r);
	return TRUE;
}
示例#24
0
int f_order(oprtype *a, opctype op)
{
	boolean_t	ok, used_glvn_slot;
	enum order_dir	direction;
	enum order_obj	object;
	int4		intval;
	opctype		gv_oc;
	oprtype		control_slot, dir_opr, *dir_oprptr, *next_oprptr;
	short int	column;
	triple		*oldchain, *r, *sav_dirref, *sav_gv1, *sav_gvn, *sav_lvn, *sav_ref, *share, *triptr;
	triple		*chain2, *obp, tmpchain2;
	save_se		save_state;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	oldchain = sav_dirref = NULL;			/* default to no direction and no shifting indirection */
	used_glvn_slot = FALSE;
	sav_gv1 = TREF(curtchain);
	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))
		{
			object = LOCAL;
			ok = lvn(&r->operand[0], OC_SRCHINDX, r);	/* 2nd arg causes us to mess below with return from lvn */
		} else
		{
			object = LOCAL_NAME;
			ok = TRUE;
			r->operand[0] = put_str((TREF(window_ident)).addr, (TREF(window_ident)).len);
			advancewindow();
		}
		next_oprptr = &r->operand[1];
		break;
	case TK_CIRCUMFLEX:
		object = GLOBAL;
		ok = gvn();
		sav_gvn = (TREF(curtchain))->exorder.bl;
		next_oprptr = &r->operand[0];
		break;
	case TK_ATSIGN:
		object = INDIRECT;
		if (SHIFT_SIDE_EFFECTS)
			START_GVBIND_CHAIN(&save_state, oldchain);
		ok = indirection(&r->operand[0]);
		next_oprptr = &r->operand[1];
		break;
	default:
		ok = FALSE;
		break;
	}
	if (!ok)
	{
		if (NULL != oldchain)
			setcurtchain(oldchain);
		stx_error(ERR_VAREXPECTED);
		return FALSE;
	}
	if (TK_COMMA != TREF(window_token))
		direction = FORWARD;	/* default direction */
	else
	{	/* two argument form: ugly logic for direction */
		advancewindow();
		column = source_column;
		dir_oprptr = (oprtype *)mcalloc(SIZEOF(oprtype));
		dir_opr = put_indr(dir_oprptr);
		sav_ref = newtriple(OC_GVSAVTARG);
		DISABLE_SIDE_EFFECT_AT_DEPTH;		/* doing this here let's us know specifically if direction had SE threat */
		if (EXPR_FAIL == expr(dir_oprptr, MUMPS_EXPR))
		{
			if (NULL != oldchain)
				setcurtchain(oldchain);
			return FALSE;
		}
		assert(TRIP_REF == dir_oprptr->oprclass);
		triptr = dir_oprptr->oprval.tref;
		if (OC_LIT == triptr->opcode)
		{	/* if direction is a literal - pick it up and stop flailing about */
			if (MV_IS_TRUEINT(&triptr->operand[0].oprval.mlit->v, &intval) && (1 == intval || -1 == intval))
			{
				direction = (1 == intval) ? FORWARD : BACKWARD;
				sav_ref->opcode = OC_NOOP;
				sav_ref = NULL;
			} else
			{	/* bad direction */
				if (NULL != oldchain)
					setcurtchain(oldchain);
				stx_error(ERR_ORDER2);
				return FALSE;
			}
		} else
		{
			direction = TBD;
			sav_dirref = newtriple(OC_GVSAVTARG);		/* $R reflects direction eval even if we revisit 1st arg */
			triptr = newtriple(OC_GVRECTARG);
			triptr->operand[0] = put_tref(sav_ref);
			switch (object)
			{
			case GLOBAL:		/* The direction may have had a side effect, so take copies of subscripts */
				*next_oprptr = *dir_oprptr;
				for (; sav_gvn != sav_gv1; sav_gvn = sav_gvn->exorder.bl)
				{	/* hunt down the gv opcode */
					gv_oc = sav_gvn->opcode;
					if ((OC_GVNAME == gv_oc) || (OC_GVNAKED == gv_oc) || (OC_GVEXTNAM == gv_oc))
						break;
				}
				assert((OC_GVNAME == gv_oc) || (OC_GVNAKED == gv_oc) || (OC_GVEXTNAM == gv_oc));
				TREF(temp_subs) = TRUE;
				create_temporaries(sav_gvn, gv_oc);
				break;
			case LOCAL:		/* Additionally need to move srchindx triple to after potential side effect */
				triptr = newtriple(OC_PARAMETER);
				triptr->operand[0] = *next_oprptr;
				triptr->operand[1] = *(&dir_opr);
				*next_oprptr = put_tref(triptr);
				sav_lvn = r->operand[0].oprval.tref;
				assert((OC_SRCHINDX == sav_lvn->opcode) || (OC_VAR == sav_lvn->opcode));
				if (OC_SRCHINDX == sav_lvn->opcode)
				{
					dqdel(sav_lvn, exorder);
					ins_triple(sav_lvn);
					TREF(temp_subs) = TRUE;
					create_temporaries(sav_lvn, OC_SRCHINDX);
				}
				assert(&r->operand[1] == next_oprptr);
				assert(TRIP_REF == next_oprptr->oprclass);
				assert(OC_PARAMETER == next_oprptr->oprval.tref->opcode);
				assert(TRIP_REF == next_oprptr->oprval.tref->operand[0].oprclass);
				sav_lvn = next_oprptr->oprval.tref->operand[0].oprval.tref;
				if ((OC_VAR == sav_lvn->opcode) || (OC_GETINDX == sav_lvn->opcode))
				{	/* lvn excludes the last subscript from srchindx and attaches it to the "parent"
					 * now we find it is an lvn and needs protection too
					 */
					triptr = maketriple(OC_STOTEMP);
					triptr->operand[0] = put_tref(sav_lvn);
					dqins(sav_lvn, exorder, triptr);		/* NOTE: violation of info hiding */
					next_oprptr->oprval.tref->operand[0].oprval.tref = triptr;
				}
				break;
			case INDIRECT:		/* Save and restore the variable lookup for true left-to-right evaluation */
				*next_oprptr = *dir_oprptr;
				used_glvn_slot = TRUE;
				dqinit(&tmpchain2, exorder);
				chain2 = setcurtchain(&tmpchain2);
				INSERT_INDSAVGLVN(control_slot, r->operand[0], ANY_SLOT, 1);
				setcurtchain(chain2);
				obp = sav_ref->exorder.bl;	/* insert before second arg */
				dqadd(obp, &tmpchain2, exorder);
				r->operand[0] = control_slot;
				break;
			case LOCAL_NAME:	/* left argument is a string - side effect can't screw it up */
				*next_oprptr = *dir_oprptr;
				break;
			default:
				assert(FALSE);
			}
			ins_triple(r);
			if (used_glvn_slot)
			{
				triptr = newtriple(OC_GLVNPOP);
				triptr->operand[0] = control_slot;
			}
			if (SE_WARN_ON && (TREF(side_effect_base))[TREF(expr_depth)])
				ISSUE_SIDEEFFECTEVAL_WARNING(column - 1);
			DISABLE_SIDE_EFFECT_AT_DEPTH;		/* usual side effect processing doesn't work for $ORDER() */
		}
	}
	if (TBD != direction)
		ins_triple(r);
	if (NULL != sav_dirref)
	{
		triptr = newtriple(OC_GVRECTARG);
		triptr->operand[0] = put_tref(sav_dirref);
	}
	r->opcode = order_opc[object][direction];		/* finally - the op code */
	if (NULL != oldchain)
		PLACE_GVBIND_CHAIN(&save_state, oldchain); 	/* shift chain back to "expr_start" */
	if (OC_FNLVNAME == r->opcode)
		*next_oprptr = put_ilit(0);			/* Flag not to return aliases with no value */
	if (OC_INDFUN == r->opcode)
		*next_oprptr = put_ilit((mint)((FORWARD == direction) ? indir_fnorder1 : indir_fnzprevious));
	*a = put_tref(r);
	return TRUE;
}
示例#25
0
int compile_pattern(oprtype *opr, bool is_indirect)
{
	ptstr		retstr;
	mval		retmval;
	mstr		instr;
	int		status;
	triple		*oldchain, tmpchain, *ref, *triptr;

	if (is_indirect)
	{
		if (shift_gvrefs)
		{
			dqinit(&tmpchain, exorder);
			oldchain = setcurtchain(&tmpchain);
			if (!indirection(opr))
			{
				setcurtchain(oldchain);
				return FALSE;
			}
			ref = newtriple(OC_INDPAT);
			newtriple(OC_GVSAVTARG);
			setcurtchain(oldchain);
			dqadd(expr_start, &tmpchain, exorder);
			expr_start = tmpchain.exorder.bl;
			triptr = newtriple(OC_GVRECTARG);
			triptr->operand[0] = put_tref(expr_start);
		} else
		{
			if (!indirection(opr))
				return FALSE;
			ref = newtriple(OC_INDPAT);
		}
		ref->operand[0] = *opr;
		*opr = put_tref(ref);
		return TRUE;
	} else
	{
		instr.addr = (char *)&source_buffer[source_column - 1];
		instr.len = strlen(instr.addr);
		status = patstr(&instr, &retstr, NULL);
		last_source_column = (short int)(instr.addr - (char *)source_buffer);
		assert(last_source_column);
		if (status)
		{	/* status == syntax error when non-zero */
			stx_error(status);
			return FALSE;
		}
		retmval.mvtype = MV_STR;
		retmval.str.len = retstr.len * sizeof(uint4);
		retmval.str.addr = stringpool.free;
		if (stringpool.top - stringpool.free < retmval.str.len)
			stp_gcol(retmval.str.len);
		memcpy(stringpool.free, &retstr.buff[0], retmval.str.len);
		stringpool.free += retmval.str.len;
		*opr = put_lit(&retmval);
		lexical_ptr = (char *)&source_buffer[last_source_column - 1];
		advancewindow();
		advancewindow();
		return TRUE;
	}
}
示例#26
0
int f_next( oprtype *a, opctype op)
{
	triple *oldchain, tmpchain, *ref, *r, *triptr;
	error_def(ERR_VAREXPECTED);
	error_def(ERR_LVORDERARG);
	error_def(ERR_GVNEXTARG);
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	r = maketriple(op);
	switch (window_token)
	{
	case TK_IDENT:
		if (director_token != TK_LPAREN)
		{
			stx_error(ERR_LVORDERARG);
			return FALSE;
		}
		if (!lvn(&(r->operand[0]),OC_SRCHINDX,r))
			return FALSE;
		ins_triple(r);
		break;
	case TK_CIRCUMFLEX:
		ref = TREF(shift_side_effects) ? TREF(expr_start) : curtchain->exorder.bl;
		if (!gvn())
			return FALSE;
		/* the following assumes OC_LIT and OC_GVNAME are all one
		 * gets for an unsubscripted global variable reference */
		if ((TREF(shift_side_effects) ? TREF(expr_start) : curtchain)->exorder.bl->exorder.bl->exorder.bl == ref)
		{
			stx_error(ERR_GVNEXTARG);
			return FALSE;
		}
		r->opcode = OC_GVNEXT;
		ins_triple(r);
		break;
	case TK_ATSIGN:
		if (TREF(shift_side_effects))
		{
			dqinit(&tmpchain, exorder);
			oldchain = setcurtchain(&tmpchain);
			if (!indirection(&(r->operand[0])))
			{
				setcurtchain(oldchain);
				return FALSE;
			}
			r->operand[1] = put_ilit((mint)indir_fnnext);
			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));
		} else
		{
			if (!indirection(&(r->operand[0])))
				return FALSE;
			r->operand[1] = put_ilit((mint)indir_fnnext);
			ins_triple(r);
		}
		r->opcode = OC_INDFUN;
		break;
	default:
		stx_error(ERR_VAREXPECTED);
		return FALSE;
	}
	*a = put_tref(r);
	return TRUE;
}
示例#27
0
void	op_indget(mval *dst, mval *target, mval *value)
{
	icode_str	indir_src;
	int		rval;
	ht_ent_mname	*tabent;
	mstr		*obj, object;
	oprtype		v;
	triple		*s, *src, *oldchain, tmpchain, *r, *triptr;
	var_tabent	targ_key;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	if ((TREF(ind_source_sp) >= TREF(ind_source_top)) || (TREF(ind_result_sp) >= TREF(ind_result_top)))
		rts_error(VARLSTCNT(1) ERR_INDMAXNEST); /* mdbcondition_handler resets ind_result_sp & ind_source_sp */
	MV_FORCE_DEFINED(value);
	MV_FORCE_STR(target);
	indir_src.str = target->str;
	indir_src.code = indir_get;
	if (NULL == (obj = cache_get(&indir_src)))
	{
		obj = &object;
		if (valid_mname(&target->str))
		{
			targ_key.var_name = target->str;
			COMPUTE_HASH_MNAME(&targ_key);
			tabent = lookup_hashtab_mname(&curr_symval->h_symtab, &targ_key);
			if (!tabent || !LV_IS_VAL_DEFINED(tabent->value))
				*dst = *value;
			else
				*dst = ((lv_val *)tabent->value)->v;
			dst->mvtype &= ~MV_ALIASCONT;	/* Make sure alias container property does not pass */
			return;
		}
		comp_init(&target->str);
		src = newtriple(OC_IGETSRC);
		switch (TREF(window_token))
		{
		case TK_IDENT:
			if (EXPR_FAIL != (rval = lvn(&v, OC_SRCHINDX, 0)))	/* NOTE assignment */
			{
				s = newtriple(OC_FNGET2);
				s->operand[0] = v;
				s->operand[1] = put_tref(src);
			}
			break;
		case TK_CIRCUMFLEX:
			if (EXPR_FAIL != (rval = gvn()))			/* NOTE assignment */
			{
				r = newtriple(OC_FNGVGET1);
				s = newtriple(OC_FNGVGET2);
				s->operand[0] = put_tref(r);
				s->operand[1] = put_tref(src);
			}
			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 (EXPR_FAIL != (rval = indirection(&v)))	/* NOTE assignment */
				{
					s = newtriple(OC_INDGET);
					s->operand[0] = v;
					s->operand[1] = put_tref(src);
					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));
				} else
					setcurtchain(oldchain);
			} else
			{
				if (EXPR_FAIL != (rval = indirection(&v)))	/* NOTE assignment */
				{
					s = newtriple(OC_INDGET);
					s->operand[0] = v;
					s->operand[1] = put_tref(src);
				}
			}
			break;
		default:
			stx_error(ERR_VAREXPECTED);
			rval = EXPR_FAIL;
			break;
		}
		v = put_tref(s);
		if (EXPR_FAIL == comp_fini(rval, obj, OC_IRETMVAL, &v, target->str.len))
			return;
		indir_src.str.addr = target->str.addr;
		cache_put(&indir_src, obj);
		/* Fall into code activation below */
	}
	*(TREF(ind_result_sp))++ = dst;
	*(TREF(ind_source_sp))++ = value;
	comp_indr(obj);
	return;
}
示例#28
0
文件: exfunc.c 项目: 5HT/mumps
int exfunc (oprtype *a)
{
	triple		*ref0, *calltrip, *masktrip, *counttrip, *funret, *tripsize;
	triple		*triptr;
	triple		tmpchain, *oldchain, *obp, *routineref, *labelref;
	error_def	(ERR_ACTOFFSET);

	assert (window_token == TK_DOLLAR);
	advancewindow();
	assert (window_token == TK_DOLLAR);
	advancewindow();
	dqinit (&tmpchain, exorder);
	oldchain = setcurtchain (&tmpchain);
	calltrip = entryref (OC_EXFUN, OC_EXTEXFUN, INDIR_DUMMY, TRUE, TRUE);
	setcurtchain (oldchain);
	if (!calltrip) return FALSE;
	if (calltrip->opcode == OC_EXFUN)
	{
		assert(calltrip->operand[0].oprclass == MLAB_REF);
		ref0 = newtriple(OC_PARAMETER);
		ref0->operand[0] = put_tsiz();		/* Need size of following code gen triple here */
		calltrip->operand[1] = put_tref(ref0);
		tripsize = ref0->operand[0].oprval.tref;
		assert(OC_TRIPSIZE == tripsize->opcode);
	}
	else
	{
		if (calltrip->opcode == OC_EXTEXFUN)
		{
			assert (calltrip->operand[1].oprclass == TRIP_REF);
			if (calltrip->operand[1].oprval.tref->opcode == OC_CDLIT)
				assert (calltrip->operand[1].oprval.tref->operand[0].oprclass == CDLT_REF);
			else
			{
			assert (calltrip->operand[1].oprval.tref->opcode == OC_LABADDR);
			assert (calltrip->operand[1].oprval.tref->operand[1].oprclass == TRIP_REF);
			assert (calltrip->operand[1].oprval.tref->operand[1].oprval.tref->opcode == OC_PARAMETER);
			assert (calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprclass == TRIP_REF);
			assert (calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprval.tref->opcode
				== OC_ILIT);
			assert
			(calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprval.tref->operand[0].oprclass
				== ILIT_REF);
			if
			(calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprval.tref->operand[0].oprval.ilit
				!= 0)
				{
					stx_error (ERR_ACTOFFSET);
					return FALSE;
				}
			}
		}
		else		/* $$ @dlabel [actuallist] */
		{
			assert (calltrip->opcode == OC_COMMARG);
			assert (calltrip->operand[1].oprclass == TRIP_REF);
			assert (calltrip->operand[1].oprval.tref->opcode == OC_ILIT);
			assert (calltrip->operand[1].oprval.tref->operand[0].oprclass == ILIT_REF);
			assert (calltrip->operand[1].oprval.tref->operand[0].oprval.ilit == INDIR_DUMMY);
			assert (calltrip->exorder.fl == &tmpchain);
			routineref = maketriple (OC_CURRHD);
			labelref = maketriple (OC_LABADDR);
			ref0 = maketriple (OC_PARAMETER);
			dqins (calltrip->exorder.bl, exorder, routineref);
			dqins (calltrip->exorder.bl, exorder, labelref);
			dqins (calltrip->exorder.bl, exorder, ref0);
			labelref->operand[0] = calltrip->operand[0];
			labelref->operand[1] = put_tref (ref0);
			ref0->operand[0] = calltrip->operand[1];
			ref0->operand[0].oprval.tref->operand[0].oprval.ilit = 0;
			ref0->operand[1] = put_tref (routineref);
			calltrip->operand[0] = put_tref (routineref);
			calltrip->operand[1] = put_tref (labelref);
			calltrip->opcode = OC_EXTEXFUN;
		}
		ref0 = newtriple (OC_PARAMETER);
		ref0->operand[0] = calltrip->operand[1];
		calltrip->operand[1] = put_tref (ref0);
	}
	if (window_token != TK_LPAREN)
	{
		masktrip = newtriple (OC_PARAMETER);
		counttrip = newtriple (OC_PARAMETER);
		masktrip->operand[0] = put_ilit (0);
		counttrip->operand[0] = put_ilit (0);
		masktrip->operand[1] = put_tref (counttrip);
		ref0->operand[1] = put_tref (masktrip);
	}
	else
		if (!actuallist (&ref0->operand[1])) return FALSE;
	obp = oldchain->exorder.bl;
	dqadd (obp, &tmpchain, exorder);		/*this is a violation of info hiding*/
	if (calltrip->opcode == OC_EXFUN)
	{
		assert(calltrip->operand[0].oprclass == MLAB_REF);
		triptr = newtriple (OC_JMP);
		triptr->operand[0] = put_mfun (&calltrip->operand[0].oprval.lab->mvname);
		calltrip->operand[0].oprclass = ILIT_REF;	/* dummy placeholder */
		tripsize->operand[0].oprval.tsize->ct = triptr;
	}

	funret = newtriple (OC_EXFUNRET);
	funret->operand[0] = *a = put_tref (calltrip);
	return TRUE;
}
示例#29
0
int compile_pattern(oprtype *opr, boolean_t is_indirect)
{
	int		status;
	ptstr		retstr;
	mval		retmval;
	mstr		instr;
	triple		*oldchain, *ref, tmpchain, *triptr;
	DCL_THREADGBL_ACCESS;

	SETUP_THREADGBL_ACCESS;
	if (is_indirect)
	{
		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(opr))
			{
				setcurtchain(oldchain);
				return FALSE;
			}
			ref = newtriple(OC_INDPAT);
			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));
		} else
		{
			if (!indirection(opr))
				return FALSE;
			ref = newtriple(OC_INDPAT);
		}
		ref->operand[0] = *opr;
		*opr = put_tref(ref);
		return TRUE;
	} else
	{
		instr.addr = (char *)&source_buffer[source_column - 1];
		instr.len = STRLEN(instr.addr);
		status = patstr(&instr, &retstr, NULL);
		TREF(last_source_column) = (short int)(instr.addr - (char *)source_buffer);
		assert(TREF(last_source_column));
		if (status)
		{	/* status == syntax error when non-zero */
			stx_error(status);
			return FALSE;
		}
		retmval.mvtype = MV_STR;
		retmval.str.len = retstr.len * SIZEOF(uint4);
		retmval.str.addr = (char *)stringpool.free;
		ENSURE_STP_FREE_SPACE(retmval.str.len);
		memcpy(stringpool.free, &retstr.buff[0], retmval.str.len);
		stringpool.free += retmval.str.len;
		*opr = put_lit(&retmval);
		lexical_ptr = instr.addr;
		advancewindow();
		advancewindow();
		return TRUE;
	}
}