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 void SubStrArgs( itnode *cit ) {
//=========================================
int count;
if( cit->typ != FT_CHAR ) {
Error( SS_ONLY_IF_CHAR );
}
count = 1;
for(;;) {
if( CITNode->opn.us & USOPN_SS1 ) {
cit->opn.us |= USOPN_SS1;
cit->value.st.ss_size = CITNode->value.st.ss_size;
}
CkScrStr();
AdvanceITPtr();
if( !RecColon() ) break;
++count;
}
}
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 bool SubStr2( intstar4 *subscripts ) {
//===============================================
// Get the second component of a substring expression.
bool got_colon;
bool hi;
subscripts++;
got_colon = RecColon();
hi = FALSE;
if( !RecNOpn() ) {
CIntExpr();
*subscripts = ITIntValue( CITNode );
hi = TRUE;
}
if( got_colon ) {
AdvanceITPtr();
}
ReqCloseParen();
ReqNOpn();
AdvanceITPtr();
return( hi );
}
void CpEquivalence(void) {
//=======================
// Compile EQUIVALENCE statement.
// EQUIVALENCE (A1,...,An) {,(B1,...,Bm)} . . .
sym_id sym;
int num_equived;
intstar4 *subscripts;
int eq_size;
act_eq_entry *new_eq;
act_eq_entry *eqv_entry;
act_eq_entry *eq_head;
act_eq_entry *eq_set;
bool ill_name;
bool sub_strung;
act_eq_entry equiv;
eq_set = EquivSets;
if( EquivSets != NULL ) {
while( eq_set->next_eq_set != NULL ) {
eq_set = eq_set->next_eq_set;
}
}
for(;;) {
if( RecNOpn() ) {
AdvanceITPtr();
}
ReqOpenParen();
eqv_entry = NULL;
eq_head = NULL;
num_equived = 0;
for(;;) {
AError = FALSE;
if( ReqName( NAME_VAR_OR_ARR ) ) {
num_equived++;
sym = LkSym();
ill_name = TRUE;
if( ( sym->ns.flags & SY_CLASS ) == SY_VARIABLE ) {
if( sym->ns.flags & SY_DATA_INIT ) {
NameErr( ST_DATA_ALREADY, sym );
} else if( sym->ns.flags & SY_SUB_PARM ) {
IllName( sym );
} else if( ( sym->ns.flags & SY_SUBSCRIPTED ) &&
_Allocatable( sym ) ) {
IllName( sym );
} else {
sym->ns.flags |= SY_IN_EQUIV;
ill_name = FALSE;
}
} else {
IllName( sym );
}
AdvanceITPtr();
equiv.name_equived = sym;
equiv.next_eq_entry = NULL;
equiv.next_eq_set = NULL;
equiv.subs_no = 0;
equiv.substr = 0;
equiv.substr1 = 1;
equiv.substr2 = 0;
subscripts = equiv.subscrs;
if( RecOpenParen() ) {
if( !RecNOpn() || !RecNextOpr( OPR_COL ) ) {
sub_strung = FALSE;
for(;;) {
CIntExpr();
*subscripts = ITIntValue( CITNode );
AdvanceITPtr();
if( RecColon() ) {
sub_strung = TRUE;
break;
}
subscripts++;
equiv.subs_no++;
if( equiv.subs_no == MAX_DIM ) break;
if( !RecComma() ) break;
}
if( !sub_strung ) {
ReqCloseParen();
ReqNOpn();
AdvanceITPtr();
if( RecOpenParen() ) {
*subscripts = 1;
if( !RecNOpn() ) {
CIntExpr();
*subscripts = ITIntValue( CITNode );
}
AdvanceITPtr();
sub_strung = ReqColon();
}
}
} else {
sub_strung = TRUE;
}
if( sub_strung ) {
equiv.substr = 1;
if( SubStr2( subscripts ) ) {
equiv.substr = 2;
}
}
}
if( AError ) {
equiv.subs_no = 0;
equiv.substr = 0;
}
if( ( ( SgmtSw & SG_SYMTAB_RESOLVED ) == 0 ) && !ill_name ) {
eq_size = sizeof( eq_entry ) +
equiv.subs_no * sizeof( intstar4 );
if( equiv.substr != 0 ) {
eq_size += 2 * sizeof( intstar4 );
}
new_eq = FMemAlloc( eq_size );
memcpy( new_eq, &equiv, eq_size );
if( eqv_entry == NULL ) {
eq_head = new_eq;
eqv_entry = new_eq;
} else {
eqv_entry->next_eq_entry = new_eq;
eqv_entry = new_eq;
}
if( sym->ns.si.va.vi.ec_ext == NULL ) {
sym->ns.si.va.vi.ec_ext = STComEq();
}
}
} else {
AdvanceITPtr();
}
if( !RecComma() ) break;
}
if( num_equived < 2 ) {
Error( EV_EQUIV_LIST );
}
if( eq_set == NULL ) {
eq_set = eq_head;
EquivSets = eq_head;
} else {
eq_set->next_eq_set = eq_head;
eq_set = eq_head;
}
ReqCloseParen();
ReqNOpn();
AdvanceITPtr();
if( !RecComma() ) break;
}
ReqEOS();
}