char* get_airsar(char* fname, char* Header, char* Record)
{
FILE* fp;
char airsar_rec[50];
int HDR=0, REC=0;
char c;
int i;
int rl;
static char chOut[256];
rl=strlen(Record);
fp=FOPEN(fname, "r");
if(strncmp(Header,"FIRST",5)==0) HDR=1;
while(!feof(fp) && !REC) {
FREAD(airsar_rec, 1, 50, fp);
if(airsar_rec[0]==0) {
while(( c = getc(fp) ) == 0) {};
ungetc(c,fp);
}
strcpy(chOut, linetail(airsar_rec));
if(!HDR)
if( !strcmp(chOut, Header) ) HDR=1;
if(HDR && !REC) {
REC = 1;
for(i=0; i<rl; i++) {
if(airsar_rec[i]!=Record[i]) {
i = rl;
REC=0;
}
}
}
}
FCLOSE(fp);
return chOut;
}
int m_for(void)
{
unsigned int arg_cnt, arg_index, for_stack_level;
oprtype arg_eval_addr[MAX_FORARGS], increment[MAX_FORARGS], terminate[MAX_FORARGS],
arg_next_addr, arg_value, dummy, control_variable,
*iteration_start_addr, iteration_start_addr_indr, *not_even_once_addr;
triple *eval_next_addr[MAX_FORARGS], *control_ref,
*forchk1opc, forpos_in_chain, *init_ref, *ref, *step_ref, *term_ref, *var_ref;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
forpos_in_chain = TREF(pos_in_chain);
FOR_PUSH();
if (TK_SPACE == TREF(window_token))
{ /* "argumentless" form */
FOR_END_OF_SCOPE(1, dummy);
ref = newtriple(OC_FORCHK1);
if (!linetail())
{
TREF(pos_in_chain) = forpos_in_chain;
assert(TREF(source_error_found));
stx_error(TREF(source_error_found));
FOR_POP(BLOWN_FOR);
return FALSE;
}
SAVE_FOR_OVER_ADDR(); /* stash address of next op in the for_stack array */
newtriple(OC_JMP)->operand[0] = put_tjmp(ref); /* transfer back to just before the begining of the body */
FOR_POP(GOOD_FOR); /* and pop the array */
return TRUE;
}
for_stack_level = (TREF(for_stack_ptr) - TADR(for_stack));
init_ref = newtriple(OC_FORNESTLVL);
init_ref->operand[0] = put_ilit(for_stack_level);
if (TK_ATSIGN == TREF(window_token))
{
if (!indirection(&control_variable))
{
FOR_POP(BLOWN_FOR);
return FALSE;
}
ref = newtriple(OC_INDLVADR);
ref->operand[0] = control_variable;
control_variable = put_tref(ref);
control_ref = NULL;
} else
{
/* The following relies on the fact that lvn() always generates an OC_VAR triple first */
control_ref = (TREF(curtchain))->exorder.bl;
if (!lvn(&control_variable, OC_SAVPUTINDX, NULL))
{
FOR_POP(BLOWN_FOR);
return FALSE;
}
assert(OC_VAR == control_ref->exorder.fl->opcode);
assert(MVAR_REF == control_ref->exorder.fl->operand[0].oprclass);
}
if (TK_EQUAL != TREF(window_token))
{
stx_error(ERR_EQUAL);
FOR_POP(BLOWN_FOR);
return FALSE;
}
newtriple(OC_PASSTHRU)->operand[0] = control_variable; /* make sure optimizer doesn't ditch control_variable */
FOR_END_OF_SCOPE(1, dummy);
assert((0 < for_stack_level) && (MAX_FOR_STACK >= for_stack_level));
if ((OC_SAVPUTINDX == control_variable.oprval.tref->opcode) || (OC_INDLVADR == control_variable.oprval.tref->opcode))
TAREF1(for_temps, for_stack_level) = TRUE_WITH_INDX; /* most uses treat this as a boolean, but some need more */
else
init_ref->opcode = OC_NOOP;
iteration_start_addr = (oprtype *)mcalloc(SIZEOF(oprtype));
iteration_start_addr_indr = put_indr(iteration_start_addr);
arg_next_addr.oprclass = NOCLASS;
not_even_once_addr = NULL; /* used to skip processing where the initial control exceeds the termination */
for (arg_cnt = 0; ; ++arg_cnt)
{
if (MAX_FORARGS <= arg_cnt)
{
stx_error(ERR_MAXFORARGS);
FOR_POP(BLOWN_FOR);
return FALSE;
}
assert((TK_COMMA == TREF(window_token)) || (TK_EQUAL == TREF(window_token)));
advancewindow();
tnxtarg(&arg_eval_addr[arg_cnt]); /* put location of this arg eval in arg_eval_addr array */
if (NULL != not_even_once_addr)
{
*not_even_once_addr = arg_eval_addr[arg_cnt];
not_even_once_addr = NULL;
}
if (EXPR_FAIL == expr(&arg_value, MUMPS_EXPR)) /* starting (possibly only) value */
{
FOR_POP(BLOWN_FOR);
return FALSE;
}
assert(TRIP_REF == arg_value.oprclass);
if (TK_COLON != TREF(window_token))
{ /* list point value? */
increment[arg_cnt].oprclass = terminate[arg_cnt].oprclass = 0;
DEAL_WITH_DANGER(for_stack_level, control_variable, arg_value);
} else
{ /* stepping value */
init_ref = newtriple(OC_STOTEMP); /* tuck it in a temp undisturbed by coming evals */
init_ref->operand[0] = arg_value;
newtriple(OC_CONUM)->operand[0] = put_tref(init_ref); /* make start numeric */
advancewindow(); /* past the first colon */
var_ref = (TREF(curtchain))->exorder.bl;
if (EXPR_FAIL == expr(&increment[arg_cnt], MUMPS_EXPR)) /* pick up step */
{
FOR_POP(BLOWN_FOR);
return FALSE;
}
assert(TRIP_REF == increment[arg_cnt].oprclass);
ref = increment[arg_cnt].oprval.tref;
if (OC_LIT != var_ref->exorder.fl->opcode)
{
if (!TAREF1(for_temps, for_stack_level))
TAREF1(for_temps, for_stack_level) = TRUE;
if (OC_VAR == var_ref->exorder.fl->opcode)
{ /* The above relies on lvn() always generating an OC_VAR triple first - asserted earlier */
step_ref = newtriple(OC_STOTEMP);
step_ref->operand[0] = put_tref(ref);
increment[arg_cnt] = put_tref(step_ref);
}
}
if (TK_COLON != TREF(window_token))
{
DEAL_WITH_DANGER(for_stack_level, control_variable, put_tref(init_ref));
terminate[arg_cnt].oprclass = 0; /* no termination on iteration for this arg */
} else
{
advancewindow(); /* past the second colon */
var_ref = (TREF(curtchain))->exorder.bl;
if (EXPR_FAIL == expr(&terminate[arg_cnt], MUMPS_EXPR)) /* termination control value */
{
FOR_POP(BLOWN_FOR);
return FALSE;
}
assert(TRIP_REF == terminate[arg_cnt].oprclass);
ref = terminate[arg_cnt].oprval.tref;
if (OC_LIT != ref->opcode)
{
if (!TAREF1(for_temps, for_stack_level))
TAREF1(for_temps, for_stack_level) = TRUE;
if (OC_VAR == var_ref->exorder.fl->opcode)
{ /* The above relies on lvn() always generating an OC_VAR triple first */
term_ref = newtriple(OC_STOTEMP);
term_ref->operand[0] = put_tref(ref);
terminate[arg_cnt] = put_tref(term_ref);
}
}
DEAL_WITH_DANGER(for_stack_level, control_variable, put_tref(init_ref));
term_ref = newtriple(OC_PARAMETER);
term_ref->operand[0] = terminate[arg_cnt];
step_ref = newtriple(OC_PARAMETER);
step_ref->operand[0] = increment[arg_cnt];
step_ref->operand[1] = put_tref(term_ref);
ref = newtriple(OC_FORINIT);
ref->operand[0] = control_variable;
ref->operand[1] = put_tref(step_ref);
not_even_once_addr = newtriple(OC_JMPGTR)->operand;
}
}
if ((0 < arg_cnt) || (TK_COMMA == TREF(window_token)))
{
if (!TAREF1(for_temps, for_stack_level))
TAREF1(for_temps, for_stack_level) = TRUE;
if (NOCLASS == arg_next_addr.oprclass)
arg_next_addr = put_tref(newtriple(OC_CDADDR));
(eval_next_addr[arg_cnt] = newtriple(OC_LDADDR))->destination = arg_next_addr;
}
if (TK_COMMA != TREF(window_token))
break;
newtriple(OC_JMP)->operand[0] = iteration_start_addr_indr;
}
if (not_even_once_addr)
FOR_END_OF_SCOPE(1, *not_even_once_addr); /* 1 means down a level */
forchk1opc = newtriple(OC_FORCHK1); /* FORCHK1 is a do-nothing routine used by the out-of-band mechanism */
*iteration_start_addr = put_tjmp(forchk1opc);
if ((TK_EOL != TREF(window_token)) && (TK_SPACE != TREF(window_token)))
{
stx_error(ERR_SPOREOL);
FOR_POP(BLOWN_FOR);
return FALSE;
}
if (!linetail())
{
TREF(pos_in_chain) = forpos_in_chain;
assert(TREF(source_error_found));
stx_error(TREF(source_error_found));
FOR_POP(BLOWN_FOR);
return FALSE;
}
SAVE_FOR_OVER_ADDR(); /* stash address of next op in the for_stack array */
if (0 < arg_cnt)
newtriple(OC_JMPAT)->operand[0] = put_tref(eval_next_addr[0]);
for (arg_index = 0; arg_index <= arg_cnt; ++arg_index)
{
if (0 < arg_cnt)
tnxtarg(eval_next_addr[arg_index]->operand);
if (TRUE_WITH_INDX == TAREF1(for_temps, for_stack_level))
{ /* since it might have moved, before touching the control variable get a fix on it */
ref = newtriple(OC_RFRSHINDX);
ref->operand[0] = put_ilit(for_stack_level);
ref->operand[1] = put_ilit((increment[arg_index].oprclass || terminate[arg_index].oprclass)
? FALSE : TRUE); /* if increment rather than new value, rfrsh w/ srchindx else putindx */
control_variable = put_tref(ref);
} else
{
assert(control_ref);
control_variable = put_mvar(&control_ref->exorder.fl->operand[0].oprval.vref->mvname);
}
newtriple(OC_PASSTHRU)->operand[0] = control_variable; /* warn off optimizer */
if (terminate[arg_index].oprclass)
{
term_ref = newtriple(OC_PARAMETER);
term_ref->operand[0] = terminate[arg_index];
step_ref = newtriple(OC_PARAMETER);
step_ref->operand[0] = increment[arg_index];
step_ref->operand[1] = put_tref(term_ref);
init_ref = newtriple(OC_PARAMETER);
init_ref->operand[0] = control_variable;
init_ref->operand[1] = put_tref(step_ref);
ref = newtriple(OC_FORLOOP);
/* redirects back to forchk1, which is at the beginning of new iteration */
ref->operand[0] = *iteration_start_addr;
ref->operand[1] = put_tref(init_ref);
} else if (increment[arg_index].oprclass)
{
step_ref = newtriple(OC_ADD);
step_ref->operand[0] = control_variable;
step_ref->operand[1] = increment[arg_index];
ref = newtriple(OC_STO);
ref->operand[0] = control_variable;
ref->operand[1] = put_tref(step_ref);
newtriple(OC_JMP)->operand[0] = *iteration_start_addr;
}
if (arg_index < arg_cnt) /* go back and evaluate the next argument */
newtriple(OC_JMP)->operand[0] = arg_eval_addr[arg_index + 1];
}
FOR_POP(GOOD_FOR);
return TRUE;
}
boolean_t line(uint4 *lnc)
{
boolean_t success;
int parmcount, varnum;
short int dot_count;
mlabel *x;
mline *curlin;
triple *first_triple, *parmbase, *parmtail, *r;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
first_triple = (TREF(curtchain))->exorder.bl;
dot_count = 0;
parmbase = NULL;
success = TRUE;
curlin = (mline *)mcalloc(SIZEOF(*curlin));
curlin->line_number = 0;
curlin->table = FALSE;
TREF(last_source_column) = 0;
if (TK_INTLIT == TREF(window_token))
int_label();
if ((TK_IDENT == TREF(window_token)) || (cmd_qlf.qlf & CQ_LINE_ENTRY))
start_fetches(OC_LINEFETCH);
else
newtriple(OC_LINESTART);
curlin->line_number = *lnc;
*lnc = *lnc + 1;
curlin->table = TRUE;
CHKTCHAIN(TREF(curtchain));
TREF(pos_in_chain) = *(TREF(curtchain));
if (TK_IDENT == TREF(window_token))
{
x = get_mladdr(&(TREF(window_ident)));
if (x->ml)
{
stx_error(ERR_MULTLAB);
success = FALSE;
} else
{
assert(NO_FORMALLIST == x->formalcnt);
x->ml = curlin;
advancewindow();
if (TK_COLON != TREF(window_token))
mlmax++;
else
{
x->gbl = FALSE;
advancewindow();
}
}
if (success && (TK_LPAREN == TREF(window_token)))
{
advancewindow();
parmbase = parmtail = newtriple(OC_BINDPARM);
for (parmcount = 0; TK_RPAREN != TREF(window_token); parmcount++)
{
if (TK_IDENT != TREF(window_token))
{
stx_error(ERR_NAMEEXPECTED);
success = FALSE;
break;
} else
{
varnum = get_mvaddr(&(TREF(window_ident)))->mvidx;
for (r = parmbase->operand[1].oprval.tref; r; r = r->operand[1].oprval.tref)
{
assert(TRIP_REF == r->operand[0].oprclass);
assert(ILIT_REF == r->operand[0].oprval.tref->operand[0].oprclass);
assert((TRIP_REF == r->operand[1].oprclass) || (0 == r->operand[1].oprclass));
if (r->operand[0].oprval.tref->operand[0].oprval.ilit == varnum)
{
stx_error(ERR_MULTFORMPARM);
success = FALSE;
break;
}
}
if (!success)
break;
r = newtriple(OC_PARAMETER);
parmtail->operand[1] = put_tref(r);
r->operand[0] = put_ilit(varnum);
parmtail = r;
advancewindow();
}
if (TK_COMMA == TREF(window_token))
advancewindow();
else if (TK_RPAREN != TREF(window_token))
{
stx_error(ERR_COMMAORRPAREXP);
success = FALSE;
break;
}
}
if (success)
{
advancewindow();
parmbase->operand[0] = put_ilit(parmcount);
x->formalcnt = parmcount;
assert(!mlabtab->lson);
if ((mlabtab->rson == x) && !TREF(code_generated))
mlabtab->formalcnt = parmcount;
}
}
}
if (success && (TK_EOL != TREF(window_token)))
{
if (TK_SPACE != TREF(window_token))
{
stx_error(ERR_LSEXPECTED);
success = FALSE;
} else
{
assert(0 == dot_count);
for (;;)
{
if (TK_SPACE == TREF(window_token))
advancewindow();
else if (TK_PERIOD == TREF(window_token))
{
dot_count++;
advancewindow();
} else
break;
}
}
if ((block_level + 1) < dot_count)
{
dot_count = (block_level > 0) ? block_level : 0;
stx_error(ERR_BLKTOODEEP);
success = FALSE;
}
}
if ((0 != parmbase) && (0 != dot_count))
{
stx_error(ERR_NESTFORMP); /* Should be warning */
success = FALSE;
dot_count = (block_level > 0 ? block_level : 0);
}
if ((block_level + 1) <= dot_count)
{
mline_tail->child = curlin;
curlin->parent = mline_tail;
block_level = dot_count;
} else
{
for (; dot_count < block_level; block_level--)
mline_tail = mline_tail->parent;
mline_tail->sibling = curlin;
curlin->parent = mline_tail->parent;
}
mline_tail = curlin;
if (success)
{
assert(TREF(for_stack_ptr) == TADR(for_stack));
*(TREF(for_stack_ptr)) = NULL;
success = linetail();
if (success)
{
assert(TREF(for_stack_ptr) == TADR(for_stack));
if (*(TREF(for_stack_ptr)))
tnxtarg(*(TREF(for_stack_ptr)));
}
}
assert(TREF(for_stack_ptr) == TADR(for_stack));
if (first_triple->exorder.fl == TREF(curtchain))
newtriple(OC_NOOP); /* empty line (comment, blank, etc) */
curlin->externalentry = first_triple->exorder.fl;
/* First_triple points to the last triple before this line was processed. Its forward link will point to a
* LINEFETCH or a LINESTART, or possibly a NOOP. It the line was a comment, there is only a LINESTART, and
* hence no "real" code yet.
*/
TREF(code_generated) = TREF(code_generated) | ((OC_NOOP != first_triple->exorder.fl->opcode)
&& (first_triple->exorder.fl->exorder.fl != TREF(curtchain)));
return success;
}
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;
}
