void InitImpDo( itnode *lastcomma ) {
//======================================
// Initialize the implied DO-loop.
int level;
itnode *imp_do_list;
CITNode = lastcomma;
CITNode->opr = OPR_TRM; // marks the end of the i/o list
ImpDo();
if( !ReqCloseParen() ) {
level = 0;
for(;;) {
if( RecOpenParen() ) {
level++;
} else if( RecCloseParen() ) {
level--;
}
if( level < 0 ) break;
if( CITNode->link == NULL ) {
DelCSNode();
CITNode->opr = OPR_TRM;
CITNode->oprpos = 9999;
break;
}
AdvanceITPtr();
}
}
ReqNOpn();
imp_do_list = lastcomma->link;
lastcomma->link = CITNode->link;
CITNode->link = NULL;
FreeITNodes( imp_do_list );
}
void DetCallList(void) {
//=====================
itnode *cit;
cit = CITNode;
AdvanceITPtr();
if( RecNOpn() ) {
AdvanceITPtr();
} else {
SetDefinedStatus();
AdvanceITPtr();
while( RecComma() ) {
if( CheckColon() ) {
Extension( SS_FUNCTION_VALUE );
SubStrArgs( cit );
Detach( cit );
return;
}
if( RecNOpn() ) break;
SetDefinedStatus();
AdvanceITPtr();
}
}
if( !RecCloseParen() ) {
Error( PC_NO_CLOSEPAREN );
}
Detach( cit );
}
void ScanExpr(void) {
//==================
// Advance CITNode to the end of the current expression.
//
// Stops on: level zero comma
// level zero colon
// unmatched right parenthesis
// terminator
int level;
level = 0;
for(;;) {
if( RecOpenParen() ) {
level++;
} else if( RecCloseParen() ) {
level--;
}
if( ( RecComma() || RecColon() ) && ( level == 0 ) ) break;
if( level < 0 ) break;
if( RecTrmOpr() ) break;
AdvanceITPtr();
}
}
static OPR FindSlash( itnode **itptr_ptr ) {
//===============================================
// Scan ahead for an OPN_DIV and replace it with OPN_TRM.
int level;
itnode *cit;
OPR opr;
cit = CITNode;
level = 0;
for(;;) {
if( RecOpenParen() ) {
level++;
} else if( RecCloseParen() ) {
level--;
}
AdvanceITPtr();
if( ( (RecDiv() || RecCat()) && (level == 0) ) || RecTrmOpr() ) {
break;
}
}
*itptr_ptr = CITNode;
opr = CITNode->opr;
CITNode->opr = OPR_TRM;
CITNode = cit;
return( opr );
}
bool StartImpDo( void ) {
//====================
// This procedure scans the i/o list to recognize an implied do.
// If it is not found false returns, if it is found true returns and:
// - the implied DO is initialized
// - a terminal operator is placed over the comma at the
// end of the i/o list within the implied DO. This is used
// as a signal to generate closing code for the implied DO.
// - the nodes containing the do list are released from
// from the internal text list.
// - a null operator is placed over the bracket at the
itnode *citnode;
itnode *lastcomma;
int level;
if( !RecNOpn() )
return( false );
if( !RecNextOpr( OPR_LBR ) )
return( false );
citnode = CITNode;
AdvanceITPtr();
lastcomma = NULL;
level = 0;
AdvanceITPtr();
for(;;) {
if( RecOpenParen() ) {
level++;
} else if( RecCloseParen() ) {
level--;
} else if( RecComma() && ( level == 0 ) ) {
lastcomma = CITNode;
}
if( ( level < 0 ) || RecTrmOpr() ) {
CITNode = citnode;
return( false );
}
AdvanceITPtr();
if( RecEquSign() && ( level == 0 ) ) {
break;
}
}
if( ( lastcomma == NULL ) || ( lastcomma->link != CITNode ) ) {
CITNode = citnode;
return( false );
}
InitImpDo( lastcomma );
CITNode = citnode;
AdvanceITPtr();
if( ( RecNextOpr( OPR_TRM ) && RecNOpn() ) ) {
Error( IL_EMPTY_IMP_DO );
}
return( true );
}
void DetSubList(void) {
//====================
itnode *cit;
int count;
byte no_subs;
itnode *save_cit;
uint ch_size;
if( CITNode->opn.us & USOPN_FLD ) {
no_subs = _DimCount( CITNode->sym_ptr->u.fd.dim_ext->dim_flags );
} else {
no_subs = _DimCount( CITNode->sym_ptr->u.ns.si.va.u.dim_ext->dim_flags );
}
count = 0;
cit = CITNode;
AdvanceITPtr();
while( RecComma() || RecFBr() ) {
if( CheckColon() ) {
if( count == 0 ) {
save_cit = CITNode;
CITNode = cit;
OpndErr( SV_TRIED_SSTR );
CITNode = save_cit;
} else if( count != no_subs ) {
Error( SV_INV_SSCR );
}
SubStrArgs( cit );
cit->opn.us &= ~USOPN_WHAT;
cit->opn.us |= USOPN_ASS;
Detach( cit );
return;
}
if( RecNOpn() ) break;
++count;
CkScrStr();
AdvanceITPtr();
}
if( !RecCloseParen() ) {
Error( PC_NO_CLOSEPAREN );
}
if( count != no_subs ) {
Error( SV_INV_SSCR );
}
// we must make sure the array isn't substrung before we can set OPN_SS1
if( !( cit->opn.us & USOPN_FLD ) && ( cit->sym_ptr->u.ns.u1.s.typ == FT_CHAR ) ) {
ch_size = cit->sym_ptr->u.ns.xt.size;
if( ch_size > 0 ) {
cit->opn.us |= USOPN_SS1;
cit->value.st.ss_size = ch_size;
}
}
Detach( cit );
}
static bool FormatIdentifier( void ) {
//====================================
if( RecComma() && RecNextOpr( OPR_EQU ) )
return false;
if( RecCloseParen() )
return false;
if( RecTrmOpr() )
return false;
ReqComma();
return true;
}
int GParms( itnode *sp ) {
//============================
// Process argument list.
int num_stmts;
sp = sp;
num_stmts = 0;
for(;;) {
if( !RecNOpn() ) { // consider f()
if( CITNode->opn.us == USOPN_STN ) {
num_stmts++;
}
}
AdvanceITPtr();
if( RecCloseParen() || RecColon() ) break;
}
return( num_stmts );
}
static void NextComma( void ) {
//=================================
int level;
AdvanceITPtr();
level = 0;
for(;;) {
if( RecOpenParen() ) {
level++;
} else if( RecCloseParen() ) {
level--;
}
if( level < 0 )
break;
if( RecEOS() )
break;
if( RecComma() && ( level == 0 ) )
break;
AdvanceITPtr();
}
}
