int f_justify( oprtype *a, opctype op)
{
triple *ref, *r;
error_def(ERR_COMMA);
r = maketriple(op);
if (!strexpr(&r->operand[0]))
return FALSE;
if (window_token != TK_COMMA)
{
stx_error(ERR_COMMA);
return FALSE;
}
advancewindow();
if (!intexpr(&r->operand[1]))
return FALSE;
if (window_token == TK_COMMA)
{
r->opcode = OC_FNJ3;
ref = newtriple(OC_PARAMETER);
ref->operand[0] = r->operand[1];
r->operand[1] = put_tref(ref);
advancewindow();
if (!intexpr(&ref->operand[1]))
return FALSE;
}
ins_triple(r);
*a = put_tref(r);
return TRUE;
}
int f_extract(oprtype *a, opctype op)
{
triple *first, *last, *r;
r = maketriple(op);
if (!strexpr(&(r->operand[0])))
return FALSE;
first = newtriple(OC_PARAMETER);
last = newtriple(OC_PARAMETER);
r->operand[1] = put_tref(first);
first->operand[1] = put_tref(last);
if (window_token != TK_COMMA)
{
first->operand[0] = last->operand[0] = put_ilit(1);
}
else
{
advancewindow();
if (!intexpr(&(first->operand[0])))
return FALSE;
if (window_token != TK_COMMA)
last->operand[0] = first->operand[0];
else
{
advancewindow();
if (!intexpr(&(last->operand[0])))
return FALSE;
}
}
ins_triple(r);
*a = put_tref(r);
return TRUE;
}
/*---------------------------------------------------------------------------*/
static void go_statement(void)
{
int linenum;
uint8_t t;
t = accept_either(TOKENIZER_TO, TOKENIZER_SUB);
if (t == TOKENIZER_TO) {
linenum = intexpr();
DEBUG_PRINTF("go_statement: go to %d.\n", linenum);
if (!statement_end())
syntax_error();
DEBUG_PRINTF("go_statement: jumping.\n");
jump_linenum(linenum);
return;
}
linenum = intexpr();
if (!statement_end())
syntax_error();
if(gosub_stack_ptr < MAX_GOSUB_STACK_DEPTH) {
gosub_stack[gosub_stack_ptr] = tokenizer_pos();
gosub_stack_ptr++;
jump_linenum(linenum);
} else {
DEBUG_PRINTF("gosub_statement: gosub stack exhausted\n");
ubasic_error("Return without gosub");
}
}
static void print_statement(void)
{
uint8_t nonl;
uint8_t t;
uint8_t nv = 0;
do {
t = current_token;
nonl = 0;
DEBUG_PRINTF("Print loop\n");
if (nv == 0) {
if(t == TOKENIZER_STRING) {
/* Handle string const specially - length rules */
tokenizer_string_func(charout, NULL);
tokenizer_next();
nv = 1;
continue;
} else if(TOKENIZER_STRINGEXP(t)) {
charoutstr(stringexpr());
nv = 1;
continue;
} else if(TOKENIZER_NUMEXP(t)) {
intout(intexpr());
nv = 1;
continue;
} else if(t == TOKENIZER_TAB) {
nv = 1;
accept_tok(TOKENIZER_TAB);
chartab(bracketed_intexpr());
continue;
} else if(t == TOKENIZER_AT) {
int x,y;
nv = 1;
accept_tok(TOKENIZER_AT);
y = intexpr();
accept_tok(TOKENIZER_COMMA);
x = intexpr();
if (move_cursor(x,y))
chpos = x;
continue;
}
}
nv = 0;
if(t == TOKENIZER_COMMA) {
charout('\t', NULL);
nonl = 1;
tokenizer_next();
} else if(t == TOKENIZER_SEMICOLON) {
nonl = 1;
tokenizer_next();
} else if (!statement_end()) {
syntax_error();
break;
}
} while(!statement_end());
if (!nonl)
charout('\n', 0);
DEBUG_PRINTF("End of print\n");
}
/*---------------------------------------------------------------------------*/
static void poke_statement(void)
{
value_t poke_addr;
value_t value;
poke_addr = intexpr();
accept_tok(TOKENIZER_COMMA);
value = intexpr();
poke_function(poke_addr, value);
}
SNODE *_genwordstmt(void)
/*
* Insert data in the code stream
*/
{
SNODE *snp;
snp = xalloc(sizeof(SNODE));
snp->next = 0;
snp->stype = st__genword;
snp->exp = 0;
getsym();
if (lastst != openpa) {
generror(ERR_PUNCT,openpa,skm_semi);
getsym();
snp = 0;
}
else {
getsym();
snp->exp = (ENODE *) intexpr(0);
if (lastst != closepa) {
generror(ERR_PUNCT,closepa,skm_semi);
snp = 0;
}
getsym();
}
if (lastst != eof)
needpunc(semicolon,0);
return(snp);
}
static void ids(node_t *sym)
{
if (token->id == ID) {
int val = 0;
do {
node_t *s = lookup(token->name, identifiers);
if (s && is_current_scope(s))
redefinition_error(source, s);
s = install(token->name, &identifiers, SCOPE);
SYM_TYPE(s) = SYM_TYPE(sym);
AST_SRC(s) = source;
SYM_SCLASS(s) = ENUM;
expect(ID);
if (token->id == '=') {
expect('=');
val = intexpr();
}
SYM_VALUE_U(s) = val++;
if (token->id != ',')
break;
expect(',');
} while (token->id == ID);
} else {
error("expect identifier");
}
}
static void bitfield(node_t *field)
{
AST_SRC(field) = source;
expect(':');
FIELD_BITSIZE(field) = intexpr();
FIELD_ISBIT(field) = true;
}
SNODE *casestmt(SNODE *lst)
/*
* cases are returned as seperate statements. for normal
* cases label is the case value and s2 is zero. for the
* default case s2 is nonzero.
*/
{ SNODE *snp;
SNODE *head=0, *tail;
snp = xalloc(sizeof(SNODE));
snp->next = 0;
if( lastst == kw_case ) {
getsym();
snp->s2 = 0;
snp->stype = st_case;
snp->label = (SNODE *)intexpr(0);
}
else if( lastst == kw_default) {
goodcode |= GF_DEF;
getsym();
snp->stype = st_case;
snp->s2 = (SNODE *)1;
}
else {
generror(ERR_NOCASE,0,0);
return 0;
}
needpunc(colon,0);
head = 0;
if (lst) {
head = tail = lst;
lst->next = 0;
}
while( lastst != end && lastst != eof &&
lastst != kw_case &&
lastst != kw_default ) {
if (goodcode & (GF_RETURN | GF_BREAK | GF_CONTINUE | GF_GOTO)) {
if (lastst == id) {
while( isspace(lastch) )
getch();
if (lastch != ':')
generror(ERR_UNREACHABLE,0,0);
}
else
generror(ERR_UNREACHABLE,0,0);
}
goodcode &= ~(GF_RETURN | GF_BREAK | GF_CONTINUE | GF_GOTO);
if( head == 0 )
head = tail = statement();
else {
tail->next = statement();
}
while( tail->next != 0 )
tail = tail->next;
}
if (goodcode & GF_BREAK)
goodcode &= ~GF_UNREACH;
snp->s1 = head;
return snp;
}
int f_ztrnlnm( oprtype *a, opctype op )
{
triple *r, *last, *ref;
int i;
bool again;
last = r = maketriple(op);
if (!strexpr(&r->operand[0]))
return FALSE;
ref = newtriple(OC_PARAMETER);
last->operand[1] = put_tref(ref);
if (window_token == TK_COMMA)
{ advancewindow();
if (window_token == TK_COMMA || window_token == TK_RPAREN)
{ ref->operand[0] = put_str("",0);
}else
{ if (!strexpr(&ref->operand[0]))
return FALSE;
}
}else
{ ref->operand[0] = put_str("",0);
}
last = ref;
ref = newtriple(OC_PARAMETER);
last->operand[1] = put_tref(ref);
if (window_token == TK_COMMA)
{ advancewindow();
if (window_token == TK_COMMA || window_token == TK_RPAREN)
{ ref->operand[0] = put_ilit(0);
}else
{ if (!intexpr(&ref->operand[0]))
return FALSE;
}
}else
{ ref->operand[0] = put_ilit(0);
}
last = ref;
again = TRUE;
for (i = 0; i < 3; i++)
{ ref = newtriple(OC_PARAMETER);
last->operand[1] = put_tref(ref);
if (again && window_token == TK_COMMA)
{ advancewindow();
if (window_token == TK_COMMA || window_token == TK_RPAREN)
{ ref->operand[0] = put_str("",0);
}else
{ if (!strexpr(&ref->operand[0]))
return FALSE;
}
}else
{ again = FALSE;
ref->operand[0] = put_str("",0);
}
last = ref;
}
ins_triple(r);
*a = put_tref(r);
return TRUE;
}
static void option_statement(void)
{
value_t r;
accept_tok(TOKENIZER_BASE);
r = intexpr();
if (r < 0 || r > 1)
ubasic_error("Invalid base");
array_base = r;
}
int f_piece(oprtype *a, opctype op)
{
mval *delim_mval;
triple *delimiter, *first, *last, *r;
oprtype x;
delimfmt unichar;
error_def(ERR_COMMA);
r = maketriple(op);
if (!strexpr(&(r->operand[0])))
return FALSE;
if (window_token != TK_COMMA)
{
stx_error(ERR_COMMA);
return FALSE;
}
advancewindow();
delimiter = newtriple(OC_PARAMETER);
r->operand[1] = put_tref(delimiter);
first = newtriple(OC_PARAMETER);
delimiter->operand[1] = put_tref(first);
if (!strexpr(&x))
return FALSE;
if (window_token != TK_COMMA)
first->operand[0] = put_ilit(1);
else
{
advancewindow();
if (!intexpr(&(first->operand[0])))
return FALSE;
}
assert(x.oprclass == TRIP_REF);
if (window_token != TK_COMMA && x.oprval.tref->opcode == OC_LIT &&
(1 == ((gtm_utf8_mode && OC_FNZPIECE != op) ? MV_FORCE_LEN(&x.oprval.tref->operand[0].oprval.mlit->v) :
x.oprval.tref->operand[0].oprval.mlit->v.str.len)))
{ /* Potential shortcut to op_fnzp1 or op_fnp1. Make some further checks */
delim_mval = &x.oprval.tref->operand[0].oprval.mlit->v;
/* Both valid chars of char_len 1 and invalid chars of byte length 1 get the fast path */
unichar.unichar_val = 0;
if (!gtm_utf8_mode || OC_FNZPIECE == op)
{ /* Single byte delimiter */
r->opcode = OC_FNZP1;
unichar.unibytes_val[0] = *delim_mval->str.addr;
} else
{ /* Potentially multiple bytes in one int */
r->opcode = OC_FNP1;
assert(SIZEOF(int) >= delim_mval->str.len);
memcpy(unichar.unibytes_val, delim_mval->str.addr, delim_mval->str.len);
}
delimiter->operand[0] = put_ilit(unichar.unichar_val);
ins_triple(r);
*a = put_tref(r);
return TRUE;
}
/*---------------------------------------------------------------------------*/
void dim_statement(void)
{
var_t v = tokenizer_variable_num();
value_t s1,s2 = 1;
int n = 1;
accept_either(TOKENIZER_STRINGVAR, TOKENIZER_INTVAR);
/* For now A-Z/A-Z$ only */
if ((v & ~STRINGFLAG) > 25)
ubasic_error("invalid array name");
accept_tok(TOKENIZER_LEFTPAREN);
s1 = intexpr();
if (accept_either(TOKENIZER_RIGHTPAREN, TOKENIZER_COMMA) == TOKENIZER_COMMA) {
s2 = intexpr();
n = 2;
accept_tok(TOKENIZER_RIGHTPAREN);
}
if (v & STRINGFLAG) {
uint8_t **p;
v &= ~STRINGFLAG;
if (stringsubs[v] || strings[v] != nullstr)
ubasic_error(redimension);
stringsubs[v] = n;
stringdim[v][0] = s1;
stringdim[v][1] = s2;
p = calloc(s1 * s2, sizeof(uint8_t *));
strings[v] = (uint8_t *)p;
for (n = 0; n < s1 * s2; n++)
*p++ = nullstr;
} else {
if (variablesubs[v])
ubasic_error(redimension);
variablesubs[v] = n;
vardim[v][0] = s1;
vardim[v][1] = s2;
vararrays[v] = calloc(s1 * s2, sizeof(uint8_t *));
}
}
int f_mint( oprtype *a, opctype op)
{
triple *r;
r = maketriple(op);
if (!intexpr(&r->operand[0]))
{ return FALSE;
}
ins_triple(r);
*a = put_tref(r);
return TRUE;
}
/*---------------------------------------------------------------------------*/
static void for_statement(void)
{
var_t for_variable;
value_t to, step = 1;
struct typevalue t;
for_variable = tokenizer_variable_num();
accept_tok(TOKENIZER_INTVAR);
accept_tok(TOKENIZER_EQ);
expr(&t);
typecheck_int(&t);
/* The set also typechecks the variable */
ubasic_set_variable(for_variable, &t, 0, NULL);
accept_tok(TOKENIZER_TO);
to = intexpr();
if (current_token == TOKENIZER_STEP) {
accept_tok(TOKENIZER_STEP);
step = intexpr();
}
if (!statement_end())
syntax_error();
/* Save a pointer to the : or CR, when we return to statements it
will do the right thing */
if(for_stack_ptr < MAX_FOR_STACK_DEPTH) {
struct for_state *fs = &for_stack[for_stack_ptr];
fs->resume_token = tokenizer_pos();
fs->for_variable = for_variable;
fs->to = to;
fs->step = step;
DEBUG_PRINTF("for_statement: new for, var %d to %d step %d\n",
fs->for_variable,
fs->to,
fs->step);
for_stack_ptr++;
} else {
DEBUG_PRINTF("for_statement: for stack depth exceeded\n");
}
}
/*---------------------------------------------------------------------------*/
static void randomize_statement(void)
{
value_t r = 0;
time_t t;
/* FIXME: replace all the CR checks with TOKENIZER_EOS() or similar so we
can deal with ':' */
if (current_token != TOKENIZER_CR)
r = intexpr();
if (r == 0) {
time(&t);
srand(getpid()^getuid()^(unsigned int)t);
} else
srand(r);
}
/*---------------------------------------------------------------------------*/
void restore_statement(void)
{
int linenum = 0;
if (!statement_end())
linenum = intexpr();
if (linenum) {
tokenizer_push();
jump_linenum(linenum);
data_position = tokenizer_pos();
tokenizer_pop();
} else
data_position = program_ptr;
data_seek = 1;
}
int f_stack(oprtype *a, opctype op)
{
triple *r;
r = maketriple(op);
if (!intexpr(&(r->operand[0])))
return FALSE;
if (window_token == TK_COMMA)
{
advancewindow();
r->opcode = OC_FNSTACK2; /*This isn't very good information hiding*/
if (!strexpr(&(r->operand[1])))
return FALSE;
}
ins_triple(r);
*a = put_tref(r);
return TRUE;
}
int f_fnzbitget( oprtype *a, opctype op)
{
triple *r;
error_def(ERR_COMMA);
r = maketriple(op);
if (!expr(&(r->operand[0]))) /* bitstring */
return FALSE;
if (window_token != TK_COMMA)
{
stx_error(ERR_COMMA);
return FALSE;
}
advancewindow();
if (!intexpr(&(r->operand[1]))) /* position */
return FALSE;
ins_triple(r);
*a = put_tref(r);
return TRUE;
}
static long ieprimary(TYP **tp)
/*
* PRimary integer
* defined(MACRO)
* id
* iconst
* (cast )intexpr
* (intexpr)
*/
{ long temp=0;
SYM *sp;
if (tp)
*tp = &stdint;
if(lastst == id) {
char *lid = lastid;
if (prm_cmangle)
lid++;
sp = gsearch(lastid);
if(sp == NULL) {
gensymerror(ERR_UNDEFINED,lastid);
getsym();
return 0;
}
if(sp->storage_class != sc_const && sp->tp->type != bt_enum) {
generror(ERR_NEEDCONST,0,0);
getsym();
return 0;
}
getsym();
return sp->value.i;
}
else if(lastst == iconst) {
temp = ival;
getsym();
return temp;
}
else if(lastst == lconst) {
if (tp)
*tp = &stdlong;
temp = ival;
getsym();
return temp;
}
else if(lastst == iuconst) {
if (tp)
*tp = &stduns;
temp = ival;
getsym();
return temp;
}
else if(lastst == luconst) {
if (tp)
*tp = &stdunsigned;
temp = ival;
getsym();
return temp;
}
else if(lastst == cconst) {
if (tp)
*tp = &stdchar;
temp = ival;
getsym();
return temp;
}
else if (lastst == openpa) {
getsym();
if (castbegin(lastst)) {
decl(0);
decl1();
needpunc(closepa,0);
if (tp)
*tp = head;
return intexpr(0);
}
else {
temp = intexpr(tp);
return(temp);
}
}
getsym();
generror(ERR_NEEDCONST,0,0);
return 0;
}
int m_job(void)
{
int argcnt;
triple *ref,*next;
oprtype label, offset, routine, plist, timeout, arglst, *argptr, argval;
static readonly unsigned char empty_plist[1] = { jp_eol };
bool is_timeout,dummybool;
error_def(ERR_MAXACTARG);
error_def(ERR_RTNNAME);
error_def(ERR_COMMAORRPARENEXP);
error_def(ERR_JOBACTREF);
label = put_str(zero_ident.c,sizeof(mident));
offset = put_ilit((mint)0);
if (!lref(&label, &offset, FALSE, indir_job, TRUE, &dummybool))
return FALSE;
if ((TRIP_REF == label.oprclass) && (OC_COMMARG == label.oprval.tref->opcode))
return TRUE;
if (TK_CIRCUMFLEX != window_token)
{
if (!run_time)
routine = put_str(routine_name,sizeof(mident));
else
routine = put_tref(newtriple(OC_CURRTN));
} else
{
advancewindow();
switch(window_token)
{
case TK_IDENT:
routine = put_str(window_ident.c,sizeof(mident));
advancewindow();
break;
case TK_ATSIGN:
if (!indirection(&routine))
return FALSE;
break;
default:
stx_error(ERR_RTNNAME);
return FALSE;
}
}
argcnt = 0;
if (TK_LPAREN == window_token)
{
advancewindow();
argptr = &arglst;
while(TK_RPAREN != window_token)
{
if (argcnt > MAX_ACTUALS)
{
stx_error(ERR_MAXACTARG);
return FALSE;
}
if (TK_PERIOD == window_token)
{
stx_error(ERR_JOBACTREF);
return FALSE;
}
if (!expr(&argval))
return FALSE;
ref = newtriple(OC_PARAMETER);
ref->operand[0] = argval;
*argptr = put_tref(ref);
argptr = &ref->operand[1];
argcnt++;
if (TK_COMMA == window_token)
advancewindow();
else if (TK_RPAREN != window_token)
{
stx_error(ERR_COMMAORRPARENEXP);
return FALSE;
}
}
advancewindow(); /* jump over close paren */
}
if (TK_COLON == window_token)
{
advancewindow();
if (TK_COLON == window_token)
{
is_timeout = TRUE;
plist = put_str((char *)empty_plist,sizeof(empty_plist));
} else
{
if (!jobparameters(&plist))
return FALSE;
is_timeout = (TK_COLON == window_token);
}
if (is_timeout)
{
advancewindow();
if (!intexpr(&timeout))
return FALSE;
} else
timeout = put_ilit(NO_M_TIMEOUT);
} else
{
is_timeout = FALSE;
plist = put_str((char *)empty_plist,sizeof(empty_plist));
timeout = put_ilit(NO_M_TIMEOUT);
}
ref = newtriple(OC_JOB);
ref->operand[0] = put_ilit(argcnt + 5); /* parameter list + five fixed arguments */
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = label;
ref = newtriple(OC_PARAMETER);
next->operand[1] = put_tref(ref);
ref->operand[0] = offset;
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = routine;
ref = newtriple(OC_PARAMETER);
next->operand[1] = put_tref(ref);
ref->operand[0] = plist;
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = timeout;
if (argcnt)
next->operand[1] = arglst;
if (is_timeout)
newtriple(OC_TIMTRU);
return TRUE;
}
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;
}
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;
}
}
}
int f_text(oprtype *a, opctype op)
{
int implicit_offset = 0;
triple *r, *label;
error_def(ERR_TEXTARG);
error_def(ERR_RTNNAME);
r = maketriple(op);
switch (window_token)
{
case TK_CIRCUMFLEX:
implicit_offset = 1;
/* CAUTION - fall-through */
case TK_PLUS:
r->operand[0] = put_str(zero_mstr.addr, 0); /* Null label - top of routine */
break;
case TK_INTLIT:
int_label();
/* CAUTION - fall through */
case TK_IDENT:
if (!(cmd_qlf.qlf & CQ_LOWER_LABELS))
lower_to_upper((uchar_ptr_t)window_ident.addr, (uchar_ptr_t)window_ident.addr, window_ident.len);
r->operand[0] = put_str(window_ident.addr, window_ident.len);
advancewindow();
break;
case TK_ATSIGN:
if (!indirection(&(r->operand[0])))
return FALSE;
r->opcode = OC_INDTEXT;
break;
default:
stx_error(ERR_TEXTARG);
return FALSE;
}
assert(TK_PLUS == window_token || TK_CIRCUMFLEX == window_token || TK_RPAREN == window_token || TK_EOL == window_token);
if (OC_INDTEXT != r->opcode || TK_PLUS == window_token || TK_CIRCUMFLEX == window_token)
{ /* Need another parm chained in to deal with offset and routine name except for the case where an
* indirect specifies the entire argument.
*/
label = newtriple(OC_PARAMETER);
r->operand[1] = put_tref(label);
}
if (TK_PLUS != window_token)
{
if (OC_INDTEXT != r->opcode || TK_CIRCUMFLEX == window_token)
/* Set default offset (0 or 1 as computed above) when offset not specified */
label->operand[0] = put_ilit(implicit_offset);
else
{ /* Fill in indirect text for case where indirect specifies entire operand */
r->opcode = OC_INDFUN;
r->operand[1] = put_ilit((mint)indir_fntext);
}
} else
{ /* Process offset */
advancewindow();
if (!intexpr(&(label->operand[0])))
return FALSE;
}
if (TK_CIRCUMFLEX != window_token)
{ /* No routine specified - default to current routine */
if (OC_INDFUN != r->opcode)
{
if (!run_time)
label->operand[1] = put_str(routine_name.addr, routine_name.len);
else
label->operand[1] = put_tref(newtriple(OC_CURRTN));
}
} else
{ /* Routine has been specified - pull it */
advancewindow();
switch(window_token)
{
case TK_IDENT:
# ifdef GTM_TRIGGER
if (TK_HASH == director_token)
/* Coagulate tokens as necessary (and available) to allow '#' in the routine name */
advwindw_hash_in_mname_allowed();
# endif
label->operand[1] = put_str(window_ident.addr, window_ident.len);
advancewindow();
break;
case TK_ATSIGN:
if (!indirection(&label->operand[1]))
return FALSE;
r->opcode = OC_INDTEXT;
break;
default:
stx_error(ERR_RTNNAME);
return FALSE;
}
}
ins_triple(r);
*a = put_tref(r);
return TRUE;
}
int m_zallocate(void)
{
triple *ref;
oprtype indopr;
bool indirect;
error_def(ERR_RPARENMISSING);
newtriple(OC_RESTARTPC);
indirect = FALSE;
newtriple(OC_LKINIT);
switch(window_token)
{
case TK_ATSIGN:
if (!indirection(&indopr))
return FALSE;
ref = newtriple(OC_COMMARG);
ref->operand[0] = indopr;
if (TK_COLON != window_token)
{
ref->operand[1] = put_ilit((mint)indir_zallocate);
return TRUE;
}
ref->operand[1] = put_ilit((mint)indir_nref);
indirect = TRUE;
break;
case TK_LPAREN:
do
{
advancewindow();
if (EXPR_FAIL == nref())
return FALSE;
} while (TK_COMMA == window_token);
if (TK_RPAREN != window_token)
{
stx_error(ERR_RPARENMISSING);
return FALSE;
}
advancewindow();
break;
default:
if (EXPR_FAIL == nref())
return FALSE;
break;
}
ref = maketriple(OC_ZALLOCATE);
if (TK_COLON != window_token)
{
ref->operand[0] = put_ilit(NO_M_TIMEOUT);
ins_triple(ref);
} else
{
advancewindow();
if (!intexpr(&(ref->operand[0])))
return EXPR_FAIL;
ins_triple(ref);
newtriple(OC_TIMTRU);
}
return EXPR_GOOD;
}
int m_zbreak(void)
{
triple *ref, *next;
oprtype label, offset, routine, action, count;
bool cancel, cancel_all, is_count, dummybool;
error_def(ERR_LABELEXPECTED);
error_def(ERR_RTNNAME);
label = put_str((char *)&zero_ident.c[0], sizeof(mident));
cancel_all = FALSE;
action = put_str("B", 1);
if (window_token == TK_MINUS)
{
advancewindow();
cancel = TRUE;
count = put_ilit((mint)CANCEL_ONE);
} else
{
cancel = FALSE;
count = put_ilit((mint)0);
}
if (window_token == TK_ASTERISK)
{
if (cancel)
{
advancewindow();
cancel_all = TRUE;
if (!run_time)
routine = put_str(&routine_name[0], sizeof(mident));
else
routine = put_tref(newtriple(OC_CURRTN));
offset = put_ilit((mint) 0);
count = put_ilit((mint) CANCEL_ALL);
} else
{
stx_error(ERR_LABELEXPECTED);
return FALSE;
}
} else
{
offset = put_ilit((mint) 0);
if (!lref(&label,&offset, TRUE, indir_zbreak, !cancel, &dummybool))
return FALSE;
if (label.oprclass == TRIP_REF && label.oprval.tref->opcode == OC_COMMARG)
return TRUE;
if (window_token != TK_CIRCUMFLEX)
{
if (!run_time)
routine = put_str(&routine_name[0], sizeof(mident));
else
routine = put_tref(newtriple(OC_CURRTN));
} else
{
advancewindow();
switch(window_token)
{
case TK_IDENT:
routine = put_str(&window_ident.c[0], sizeof(mident));
advancewindow();
break;
case TK_ATSIGN:
if (!indirection(&routine))
return FALSE;
break;
default:
stx_error(ERR_RTNNAME);
return FALSE;
}
}
if (!cancel && window_token == TK_COLON)
{
advancewindow();
if (window_token == TK_COLON)
{
is_count = TRUE;
action = put_str("B",1);
} else
{
if (!strexpr(&action))
return FALSE;
is_count = window_token == TK_COLON;
}
if (is_count)
{
advancewindow();
if (!intexpr(&count))
return FALSE;
}
}
}
ref = newtriple(OC_SETZBRK);
ref->operand[0] = label;
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = offset;
ref = newtriple(OC_PARAMETER);
next->operand[1] = put_tref(ref);
ref->operand[0] = routine;
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = action;
ref = newtriple(OC_PARAMETER);
next->operand[1] = put_tref(ref);
ref->operand[0] = count;
return TRUE;
}
int f_char(oprtype *a, opctype op)
{
triple *root, *last, *curr;
oprtype argv[CHARMAXARGS], *argp;
mval v;
boolean_t all_lits;
unsigned char *base, *outptr, *tmpptr;
int argc, ch, size, char_len;
error_def(ERR_FCHARMAXARGS);
error_def(ERR_INVDLRCVAL);
/* If we are not in UTF8 mode, we need to reroute to the $ZCHAR function to
handle things correctly.
*/
if (!gtm_utf8_mode)
return f_zchar(a, op);
all_lits = TRUE;
argp = &argv[0];
argc = 0;
for (;;)
{
if (!intexpr(argp))
return FALSE;
assert(argp->oprclass == TRIP_REF);
if (argp->oprval.tref->opcode != OC_ILIT)
all_lits = FALSE;
argc++;
argp++;
if (window_token != TK_COMMA)
break;
advancewindow();
if (argc >= CHARMAXARGS)
{
stx_error(ERR_FCHARMAXARGS);
return FALSE;
}
}
if (all_lits)
{ /* All literals, build the function inline */
size = argc * GTM_MB_LEN_MAX;
ENSURE_STP_FREE_SPACE(size);
base = stringpool.free;
argp = &argv[0];
for (outptr = base, char_len = 0; argc > 0; --argc, argp++)
{ /* For each wide char value, convert to unicode chars in stringpool buffer */
ch = argp->oprval.tref->operand[0].oprval.ilit;
if (ch >= 0)
{ /* As per the M standard, negative code points should map to no characters */
tmpptr = UTF8_WCTOMB(ch, outptr);
assert(tmpptr - outptr <= 4);
if (tmpptr != outptr)
++char_len; /* yet another valid character. update the character length */
else if (!badchar_inhibit)
stx_error(ERR_INVDLRCVAL, 1, ch);
outptr = tmpptr;
}
}
stringpool.free = outptr;
MV_INIT_STRING(&v, outptr - base, base);
v.str.char_len = char_len;
v.mvtype |= MV_UTF_LEN;
s2n(&v);
*a = put_lit(&v);
return TRUE;
}
root = maketriple(op);
root->operand[0] = put_ilit(argc + 1);
last = root;
argp = &argv[0];
for (; argc > 0 ;argc--, argp++)
{
curr = newtriple(OC_PARAMETER);
curr->operand[0] = *argp;
last->operand[1] = put_tref(curr);
last = curr;
}
ins_triple(root);
*a = put_tref(root);
return TRUE;
}
int m_write(void)
{
error_def(ERR_STRINGOFLOW);
oprtype x,*oprptr;
mval lit;
mstr *msp;
int lnx;
char *cp;
triple *ref, *t1;
triple *litlst[128], **llptr, **ptx, **ltop;
llptr = litlst;
ltop = 0;
*llptr = 0;
for (;;)
{
devctlexp = FALSE;
switch(window_token)
{
case TK_ASTERISK:
advancewindow();
if (!intexpr(&x))
return FALSE;
assert(x.oprclass == TRIP_REF);
ref = newtriple(OC_WTONE);
ref->operand[0] = x;
STO_LLPTR((x.oprval.tref->opcode == OC_ILIT) ? ref : 0);
break;
case TK_QUESTION:
case TK_EXCLAIMATION:
case TK_HASH:
case TK_SLASH:
if (!rwformat())
return FALSE;
STO_LLPTR(0);
break;
default:
switch (strexpr(&x))
{
case EXPR_FAIL:
return FALSE;
case EXPR_GOOD:
assert(x.oprclass == TRIP_REF);
if (devctlexp)
{
ref = newtriple(OC_WRITE);
ref->operand[0] = x;
STO_LLPTR(0);
} else if (x.oprval.tref->opcode == OC_CAT)
{
wrtcatopt(x.oprval.tref,&llptr,LITLST_TOP);
} else
{
ref = newtriple(OC_WRITE);
ref->operand[0] = x;
STO_LLPTR((x.oprval.tref->opcode == OC_LIT) ? ref : 0);
}
break;
case EXPR_INDR:
make_commarg(&x,indir_write);
STO_LLPTR(0);
break;
default:
assert(FALSE);
}
break;
}
if (window_token != TK_COMMA)
break;
advancewindow();
if (llptr >= LITLST_TOP)
{
*++llptr = 0;
ltop = llptr;
llptr = 0;
}
}
STO_LLPTR(0);
if (ltop)
llptr = ltop;
for (ptx = litlst ; ptx < llptr ; ptx++)
{
if (*ptx && *(ptx + 1))
{
lit.mvtype = MV_STR;
lit.str.addr = cp = (char * ) stringpool.free;
for (t1 = ref = *ptx++ ; ref ; ref = *ptx++)
{
if (ref->opcode == OC_WRITE)
{
msp = &(ref->operand[0].oprval.tref->operand[0].oprval.mlit->v.str);
lnx = msp->len;
if ( cp + lnx > (char *) stringpool.top)
{ stx_error(ERR_STRINGOFLOW);
return FALSE;
}
memcpy(cp, msp->addr, lnx);
cp += lnx;
}
else
{
assert(ref->opcode == OC_WTONE);
if (cp + 1 > (char *) stringpool.top)
{ stx_error(ERR_STRINGOFLOW);
return FALSE;
}
*cp++ = ref->operand[0].oprval.tref->operand[0].oprval.ilit;
}
ref->operand[0].oprval.tref->opcode = OC_NOOP;
ref->opcode = OC_NOOP;
ref->operand[0].oprval.tref->operand[0].oprclass = OC_NOOP;
ref->operand[0].oprclass = 0;
}
ptx--;
stringpool.free = (unsigned char *) cp;
lit.str.len = INTCAST(cp - lit.str.addr);
s2n(&lit);
t1->opcode = OC_WRITE;
t1->operand[0] = put_lit(&lit);
}
}
return TRUE;
}
triple *entryref(opctype op1, opctype op2, mint commargcode, boolean_t can_commarg, boolean_t labref, boolean_t textname)
{
oprtype offset, label, routine, rte1;
char rtn_text[SIZEOF(mident_fixed)], lab_text[SIZEOF(mident_fixed)];
mident rtnname, labname;
mstr rtn_str, lbl_str;
triple *ref, *next, *rettrip;
boolean_t same_rout;
rtnname.len = labname.len = 0;
rtnname.addr = &rtn_text[0];
labname.addr = &lab_text[0];
/* These cases don't currently exist but if they start to exist, the code in this
* routine needs to be revisited for proper operation as the textname conditions
* were assumed not to happen if can_commarg was FALSE (which it is in the one
* known use of textname TRUE - in m_zgoto).
*/
assert(!(can_commarg && textname));
switch (window_token)
{
case TK_INTLIT:
int_label();
/* caution: fall through */
case TK_IDENT:
memcpy(labname.addr, window_ident.addr, window_ident.len);
labname.len = window_ident.len;
advancewindow();
if ((TK_PLUS != window_token) && (TK_CIRCUMFLEX != window_token) && !IS_MCODE_RUNNING && can_commarg)
{
rettrip = newtriple(op1);
rettrip->operand[0] = put_mlab(&labname);
return rettrip;
}
label.oprclass = 0;
break;
case TK_ATSIGN:
if(!indirection(&label))
return NULL;
if ((TK_PLUS != window_token) && (TK_CIRCUMFLEX != window_token) && (TK_COLON != window_token)
&& can_commarg)
{
rettrip = ref = maketriple(OC_COMMARG);
ref->operand[0] = label;
ref->operand[1] = put_ilit(commargcode);
ins_triple(ref);
return rettrip;
}
labname.len = 0;
break;
case TK_PLUS:
stx_error(ERR_LABELEXPECTED);
return NULL;
default:
labname.len = 0;
label.oprclass = 0;
break;
}
if (!labref && (TK_PLUS == window_token))
{ /* Have line offset specified */
advancewindow();
if (!intexpr(&offset))
return NULL;
} else
offset.oprclass = 0;
if (TK_CIRCUMFLEX == window_token)
{ /* Have a routine name specified */
advancewindow();
switch(window_token)
{
case TK_IDENT:
MROUT2XTERN(window_ident.addr, rtnname.addr, window_ident.len);
rtn_str.len = rtnname.len = window_ident.len;
rtn_str.addr = rtnname.addr;
advancewindow();
if (!IS_MCODE_RUNNING)
{ /* Triples for indirect code */
same_rout = (MIDENT_EQ(&rtnname, &routine_name) && can_commarg);
if (!textname)
{ /* Resolve routine and label names to addresses for most calls */
if (!label.oprclass && !offset.oprclass)
{ /* Routine only (no label or offset) */
if (same_rout)
{
rettrip = newtriple(op1);
rettrip->operand[0] = put_mlab(&labname);
} else
{
rettrip = maketriple(op2);
if (rtnname.addr[0] == '%')
rtnname.addr[0] = '_';
rettrip->operand[0] = put_cdlt(&rtn_str);
mlabel2xtern(&lbl_str, &rtnname, &labname);
rettrip->operand[1] = put_cdlt(&lbl_str);
ins_triple(rettrip);
}
return rettrip;
} else if (!same_rout)
{
rte1 = put_str(rtn_str.addr, rtn_str.len);
if (rtnname.addr[0] == '%')
rtnname.addr[0] = '_';
routine = put_cdlt(&rtn_str);
ref = newtriple(OC_RHDADDR);
ref->operand[0] = rte1;
ref->operand[1] = routine;
routine = put_tref(ref);
} else
routine = put_tref(newtriple(OC_CURRHD));
} else
{ /* Return the actual names used */
if (!label.oprclass && !offset.oprclass)
{ /* Routine only (no label or offset) */
rettrip = maketriple(op2);
rettrip->operand[0] = put_str(rtn_str.addr, rtn_str.len);
ref = newtriple(OC_PARAMETER);
ref->operand[0] = put_str(labname.addr, labname.len);
ref->operand[1] = put_ilit(0);
rettrip->operand[1] = put_tref(ref);
ins_triple(rettrip);
return rettrip;
} else
routine = put_str(rtn_str.addr, rtn_str.len);
}
} else
{ /* Triples for normal compiled code */
routine = put_str(rtn_str.addr, rtn_str.len);
if (!textname)
{ /* If not returning text name, convert text name to routine header address */
ref = newtriple(OC_RHDADDR1);
ref->operand[0] = routine;
routine = put_tref(ref);
}
}
break;
case TK_ATSIGN:
if (!indirection(&routine))
return NULL;
if (!textname)
{ /* If not returning text name, convert text name to routine header address */
ref = newtriple(OC_RHDADDR1);
ref->operand[0] = routine;
routine = put_tref(ref);
}
break;
default:
stx_error(ERR_RTNNAME);
return NULL;
}
} else
{
if (!label.oprclass && (0 == labname.len))
{
stx_error(ERR_LABELEXPECTED);
return NULL;
}
if (!textname)
routine = put_tref(newtriple(OC_CURRHD));
else
{ /* If we need a name, the mechanism to retrieve it differs between normal and indirect compilation */
if (!IS_MCODE_RUNNING)
/* For normal compile, use routine name set when started compile */
routine = put_str(routine_name.addr, routine_name.len);
else
/* For an indirect compile, obtain the currently running routine header and pull the routine
* name out of that.
*/
routine = put_str(frame_pointer->rvector->routine_name.addr,
frame_pointer->rvector->routine_name.len);
}
}
if (!offset.oprclass)
offset = put_ilit(0);
if (!label.oprclass)
label = put_str(labname.addr, labname.len);
ref = textname ? newtriple(OC_PARAMETER) : newtriple(OC_LABADDR);
ref->operand[0] = label;
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = offset;
if (!textname)
next->operand[1] = routine; /* Not needed if giving text names */
rettrip = next = newtriple(op2);
next->operand[0] = routine;
next->operand[1] = put_tref(ref);
return rettrip;
}
int f_char(oprtype *a, opctype op)
{
triple *root, *last, *curr;
oprtype argv[CHARMAXARGS], *argp;
mval v;
bool all_lits;
char *c;
int argc, i;
error_def(ERR_FCHARMAXARGS);
all_lits = TRUE;
argp = &argv[0];
argc = 0;
for (;;)
{
if (!intexpr(argp))
return FALSE;
assert(argp->oprclass == TRIP_REF);
if (argp->oprval.tref->opcode != OC_ILIT)
all_lits = FALSE;
argc++;
argp++;
if (window_token != TK_COMMA)
break;
advancewindow();
if (argc >= CHARMAXARGS)
{ stx_error(ERR_FCHARMAXARGS);
return FALSE;
}
}
if (all_lits)
{
if (stringpool.top - stringpool.free < argc)
stp_gcol(argc);
v.mvtype = MV_STR;
v.str.addr = c = (char *) stringpool.free;
argp = &argv[0];
for (; argc > 0 ;argc--, argp++)
{
i = argp->oprval.tref->operand[0].oprval.ilit;
if ((i >= 0) && (i < 256)) /* only true for single byte character set */
*c++ = i;
}
v.str.len = c - v.str.addr;
stringpool.free =(unsigned char *) c;
s2n(&v);
*a = put_lit(&v);
return TRUE;
}
root = maketriple(op);
root->operand[0] = put_ilit(argc + 2);
curr = newtriple(OC_PARAMETER);
curr->operand[0] = put_ilit(0);
root->operand[1] = put_tref(curr);
last = curr;
argp = &argv[0];
for (; argc > 0 ;argc--, argp++)
{
curr = newtriple(OC_PARAMETER);
curr->operand[0] = *argp;
last->operand[1] = put_tref(curr);
last = curr;
}
ins_triple(root);
*a = put_tref(root);
return TRUE;
}
