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 );
}
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 FormatIdd( void ) {
//=========================
cs_label fmt_label;
grp_entry *ge;
if( RecName() && ( NameListFind() != NULL ) ) {
BIOutNameList( CITNode->sym_ptr );
ge = CITNode->sym_ptr->u.nl.group_list;
while( ge != NULL ) {
ge->sym->u.ns.flags |= SY_REFERENCED;
ge = ge->link;
}
GSetNameList( FC_SET_NML );
KWRememb( IO_NAMELIST );
} else if( RecNumber() ) {
GPassStmtNo( LkUpFormat(), FC_SET_FMT );
} else if( RecNOpn() && RecNextOpr( OPR_MUL ) ) {
if( CITNode->link->opn.ds == DSOPN_PHI ) {
AdvanceITPtr(); // nothing needs to be loaded for default
KWRememb( IO_LIST_DIR );
}
} else if( RecNOpn() && RecNextOpr( OPR_COM ) ) {
Extension( IL_NO_ASTERISK );
} else if( RecIntVar() ) {
CkVarRef();
StNumbers.var_format = true;
GFmtVarSet();
} else {
ProcIOExpr(); // will allow for array name alone
if( !AError ) {
if( RecArrName() ) {
if( CITNode->typ != FT_CHAR ) {
Extension( IL_NON_CHARACTER );
}
ChkAssumed();
GFmtArrSet();
} else if( CITNode->typ != FT_CHAR ) {
Error( IL_BAD_FMT_SPEC );
} else if( ( CITNode->opn.us == USOPN_CON ) ) {
AddConst( CITNode ); // in case single constant
fmt_label.g_label = NextLabel();
FScan( CITNode->sym_ptr->u.lt.length,
(char *)&CITNode->sym_ptr->u.lt.value, fmt_label );
GPassLabel( fmt_label.g_label, RT_SET_FMT );
} else {
GFmtExprSet();
}
}
}
}
void Unit(void) {
//===============
if( RecNOpn() && RecNextOpr( OPR_MUL ) ) {
if( ( StmtProc != PR_READ ) && ( StmtProc != PR_WRITE ) ) {
StmtErr( IL_STAR_NOT_ALLOWED );
}
AdvanceITPtr();
ReqNOpn();
} else {
ProcIOExpr();
if( !AError ) {
if( _IsTypeInteger( CITNode->typ ) && !RecArrName() ) {
GPassValue( FC_SET_UNIT );
} else if( CITNode->typ == FT_CHAR ) {
KWRememb( IO_INTERNAL );
CkAssignOk();
if( RecArrName() ) {
ChkAssumed();
GArrIntlSet();
} else {
GIntlSet();
}
if( ( StmtProc != PR_READ ) &&
( StmtProc != PR_WRITE ) &&
( StmtProc != PR_PRINT ) ) {
Error( IL_BAD_INTL );
}
} else {
Error( IL_NO_UNIT_ID );
}
}
}
}
void CpReturn( void )
{
if( !(ProgSw & PS_IN_SUBPROGRAM) ) {
Extension( RE_IN_PROGRAM );
}
CkRemBlock();
if( RecNOpn() && RecNextOpr( OPR_TRM ) ) {
if( ( ( SubProgId->u.ns.flags & SY_CLASS ) == SY_SUBPROGRAM ) &&
( ( SubProgId->u.ns.flags & SY_SUBPROG_TYPE ) == SY_SUBROUTINE ) ) {
GNullRetIdx();
}
} else {
IntSubExpr();
if( ( ( SubProgId->u.ns.flags & SY_CLASS ) == SY_SUBPROGRAM ) &&
( ( SubProgId->u.ns.flags & SY_SUBPROG_TYPE ) == SY_SUBROUTINE ) ) {
GRetIdx();
} else {
Error( RE_ALT_IN_SUBROUTINE );
}
}
AdvanceITPtr();
ReqEOS();
GGotoEpilog();
Remember.transfer = true;
Remember.stop_or_return = true;
}
void CpPrint( void ) {
//=================
// Compile PRINT statement.
itnode *cit;
InitIO();
Form();
if( !RecEOS() ) {
ReqComma();
if( RecNOpn() ) {
cit = CITNode;
AdvanceITPtr();
if( RecEOS() ) {
CITNode = cit;
Error( SX_SURP_OPR );
}
CITNode = cit;
}
}
IOList();
ReqEOS();
FiniIO();
}
static bool ReadKWList( void ) {
//====================================
OPR opr;
if( Scan4ListOprs() )
return( true );
if( SPtr1->opn.ds != DSOPN_PHI )
return( true ); // have ( ciolist ) name
opr = SPtr1->link->opr;
if( opr == OPR_COM )
return( false ); // have ( fmt ),
if( opr == OPR_LBR )
return( true ); // we have ( ciolist ) (a(i) i==1,10)
if( opr != OPR_TRM )
return( false );
if( RecNOpn() )
return( false );
if( CITNode->opn.ds == DSOPN_LIT )
return( false );
if( CITNode->opn.ds > DSOPN_LIT )
return( true );
if( LkSym()->u.ns.u1.s.typ == FT_CHAR )
return( false );
return( true );
}
void CpData(void) {
//================
// Compile DATA statement.
label_id end_data;
int data_sets;
bool error;
// so that we can issue ST_DATA_TOO_EARLY later
SgmtSw |= SG_SEEN_DATA;
error = false;
data_sets = 0;
CITNode->opr = OPR_COM; // prevent call to FinishImpDo first time
end_data = GDataProlog();
for(;;) {
DoData();
error |= AError;
++data_sets;
if( RecNOpn() ) {
AdvanceITPtr();
if( RecTrmOpr() )
break;
ReqComma();
}
if( RecTrmOpr() || error ) {
break;
}
}
if( !error ) {
DumpDataSets( data_sets, ITHead );
}
GDataEpilog( end_data );
CITNode->opr = OPR_TRM;
}
void CpWhile( void )
{
//=================
// Compile a WHILE statement.
// WHILE( expr )DO <:label> -- block while
// WHILE( expr ) <:label> -- block while
// WHILE( expr ) STATEMENT -- one line while
CSExtn();
InitLoop( CS_WHILE );
CSCond( CSHead->bottom );
if( RecNOpn() && RecNextOpr( OPR_COL ) ) {
BlockLabel();
} else if( RecKeyWord( "DO" ) &&
( RecNextOpr( OPR_TRM ) || RecNextOpr( OPR_COL ) ) ) {
CITNode->opn.ds = DSOPN_PHI;
BlockLabel();
} else {
Recurse();
GLabel( CSHead->cycle );
FiniLoop();
DelCSNode();
}
}
void CpSave( void ) {
//================
// Compile SAVE statement : SAVE A1 {,A2 ... }
//
// where Ai is 1. a common block name preceded and followed by a /
// 2. an array name
// 3. a variable name
sym_id sym_ptr;
if( RecNOpn() && RecNextOpr( OPR_TRM ) ) {
if( ( (SgmtSw & SG_LITTLE_SAVE) != 0 ) || ( (SgmtSw & SG_BIG_SAVE) != 0 ) ) {
Error( SA_SAVED );
}
SgmtSw |= SG_BIG_SAVE;
} else {
for( ;; ) {
if( RecNOpn() && RecNextOpr( OPR_DIV ) ) {
AdvanceITPtr();
if( ReqName( NAME_COMMON ) ) {
sym_ptr = LkCommon();
if( sym_ptr->u.ns.flags == 0 ) {
sym_ptr->u.ns.flags |= SY_USAGE | SY_COMMON;
}
Save( sym_ptr );
}
AdvanceITPtr();
ReqDiv();
ReqNOpn();
} else if( ReqName( NAME_VAR_OR_ARR ) ) {
sym_ptr = LkSym();
if( ( sym_ptr->u.ns.flags & ~SV_ON_OR_OFF ) != SY_VARIABLE ) {
IllName( sym_ptr );
} else {
Save( sym_ptr );
}
}
AdvanceITPtr();
if( !RecComma() ) {
break;
}
}
ReqEOS();
}
}
bool ReqNOpn( void ) {
//=================
if( RecNOpn() )
return( true );
OpndErr( SX_UNEXPECTED_OPN );
return( false );
}
static void Detach( itnode *cit ) {
//=====================================
cit->list = cit->link;
cit->link = CITNode->link;
if( !RecNOpn() ) {
Error( SX_NO_OPR );
}
CITNode->link = NULL;
CITNode = cit;
}
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 void NumOrLit( FCODE routine ) {
//===============================================
if( RecNOpn() ) {
AdvanceITPtr();
}
if( RecNOpn() ) {
GBreak( routine );
} else if( !RecLiteral() ) {
if( CITNode->opn.ds == DSOPN_INT ) {
if( CITNode->opnd_size > 5 ) {
Extension( ST_LONG_NUM, StmtKeywords[ StmtProc ] );
}
BreakOpn( routine );
} else {
Error( SX_NUM_OR_LIT );
}
} else {
BreakOpn( routine );
}
}
static void DoKWList( void ) {
//==========================
// Call KeywordList() and check for closing parenthesis.
KeywordList();
if( ReqCloseParen() ) {
if( !RecNOpn() ) {
Error( SX_EOS_EXPECTED );
}
AdvanceITPtr();
}
}
void CpEnd(void) {
//===============
LFSkip();
if( RecNOpn() ) {
ProgSw |= PS_END_OF_SUBPROG;
AdvanceITPtr();
Remember.endstmt = true;
ReqEOS();
} else {
BadStmt();
}
}
static void JustList( void ) {
//==========================
// The io statement must have a keyword list in brackets.
InitIO();
if( RecTrmOpr() && RecNOpn() ) {
AdvanceITPtr();
}
if( ReqOpenParen() ) {
DoKWList();
}
ReqEOS();
GStartIO();
FiniIO();
}
void CpWrite( void ) {
//=================
// Compile WRITE statement.
InitIO();
if( RecTrmOpr() && RecNOpn() ) {
AdvanceITPtr();
}
if( ReqOpenParen() ) {
KeywordList();
ReqCloseParen();
IOList();
}
ReqEOS();
FiniIO();
}
void IOList( void ) {
//================
// Process the input/output list.
GStartIO();
if( CITNode->link != NULL ) {
if( RecNOpn() && RecNextOpr( OPR_TRM ) ) {
AdvanceITPtr(); // WRITE(6,3)
} else if( Already( IO_NAMELIST ) ) {
Error( IL_NO_IOLIST );
}
for(;;) {
if( CITNode->link == NULL ) break;
ProcessList();
}
}
GStopIO();
}
static void UnitOrList( void ) {
//============================
// The io statement can have a unit id by itself or have a keyword list
// in brackets.
InitIO();
if( RecNextOpr( OPR_LBR ) && RecNOpn() ) {
AdvanceITPtr();
DoKWList();
} else {
Permission( IO_UNIT ); // remembers unit= specified
Unit();
AdvanceITPtr();
}
ReqEOS();
GStartIO();
FiniIO();
}
static void GetSConst( void ) {
//===========================
// Signed constant converting without downscan-upscan process.
int sign;
if( RecNOpn() ) {
sign = 1;
if( RecNextOpr( OPR_MIN ) ) {
sign = -1;
} else if( !RecNextOpr( OPR_PLS ) ||
( CITNode->link->opn.ds < DSOPN_INT ) ) {
ProcDataIExpr();
return;
}
AdvanceITPtr();
ProcDataIExpr();
switch( CITNode->typ ) {
case FT_INTEGER_1:
CITNode->value.intstar1 *= sign;
break;
case FT_INTEGER_2:
CITNode->value.intstar2 *= sign;
break;
case FT_INTEGER:
CITNode->value.intstar4 *= sign;
break;
case FT_REAL:
CITNode->value.single *= sign;
break;
case FT_DOUBLE:
CITNode->value.dble *= sign;
break;
case FT_TRUE_EXTENDED:
CITNode->value.extended *= sign;
break;
}
} else {
ProcDataIExpr();
}
}
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 DumpDataSets( int num, itnode *node ) {
//=====================================================
// Dump the constants for data initialization.
itnode *rpt;
GStopIO();
CITNode = node;
GBegDList();
while( --num >= 0 ) {
for(;;) {
AdvanceITPtr();
if( RecDiv() ) {
break;
}
}
for(;;) {
if( RecNextOpr( OPR_MUL ) ) {
rpt = CITNode;
AdvanceITPtr();
} else {
rpt = NULL;
}
if( RecNOpn() ) { // jump over optional sign.
AdvanceITPtr();
}
GDataItem( rpt );
AdvanceITPtr();
if( RecDiv() ) {
break;
}
}
GEndDSet();
}
GEndDList();
}
void ListItem( void ) {
//==================
// Process one list item.
sym_id sd;
if( RecNOpn() ) {
if( !CpError ) {
Error( SX_SURP_OPR );
}
} else if( RecArrName() ) {
CITNode->sym_ptr->ns.u1.s.xflags |= SY_DEFINED;
ChkAssumed();
if( CITNode->typ == FT_STRUCTURE ) {
ChkStructIO( CITNode->sym_ptr->ns.xt.sym_record );
GIOStructArray();
} else {
GIOArray();
}
} else if( CITNode->typ == FT_STRUCTURE ) {
CITNode->sym_ptr->ns.u1.s.xflags |= SY_DEFINED;
if( CITNode->opn.us & USOPN_FLD ) {
sd = CITNode->value.st.field_id->fd.xt.sym_record;
} else {
sd = CITNode->sym_ptr->ns.xt.sym_record;
}
ChkStructIO( sd );
GIOStruct( sd );
} else {
if( StmtProc == PR_READ ) {
CkAssignOk();
}
GIOItem();
}
AdvanceITPtr();
}
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 );
}
static void Generate( void ) {
//================================
// Generate code.
TYPE typ1;
TYPE typ2;
OPTR op;
OPR opr;
itnode *next;
unsigned_16 mask;
uint res_size;
next = CITNode->link;
if( next->opn.ds == DSOPN_PHI ) {
BadSequence();
} else {
typ1 = CITNode->typ;
typ2 = next->typ;
opr = next->opr;
if( RecNOpn() ) {
typ1 = FT_NO_TYPE;
CITNode->size = next->size;
if( (opr != OPR_PLS) && (opr != OPR_MIN) && (opr != OPR_NOT) ) {
BadSequence();
return;
}
}
op = OprNum[ opr ];
if( typ1 == FT_NO_TYPE ) {
mask = LegalOprsU[ typ2 - FT_FIRST ];
} else {
mask = LegalOprsB[ ( typ2 - FT_FIRST ) * LEGALOPR_TAB_COLS + typ1 - FT_FIRST ];
}
if( (( mask >> ( op - OPTR_FIRST ) ) & 1) == 0 ) {
// illegal combination
MoveDown();
if( typ1 == FT_NO_TYPE ) {
TypeErr( MD_UNARY_OP, typ2 );
} else if( typ1 == typ2 ) {
TypeErr( MD_ILL_OPR, typ1 );
} else {
TypeTypeErr( MD_MIXED, typ1, typ2 );
}
BackTrack();
} else if( DoGenerate( typ1, typ2, &res_size ) ) {
if( ( opr >= OPR_FIRST_RELOP ) && ( opr <= OPR_LAST_RELOP ) &&
( (ResultType == FT_COMPLEX) || (ResultType == FT_DCOMPLEX) ||
(ResultType == FT_XCOMPLEX) ) &&
( opr != OPR_EQ ) && ( opr != OPR_NE ) ) {
// can only compare complex with .EQ. and .NE.
Error( MD_RELOP_OPND_COMPLEX );
} else {
if( ( next->opn.us == USOPN_CON ) &&
( ( CITNode->opn.us == USOPN_CON ) || ( typ1 == FT_NO_TYPE ) ) ) {
// we can do some constant folding
ConstTable[ op ]( typ1, typ2, op );
} else {
// we have to generate code
if( CITNode->opn.us == USOPN_CON ) {
AddConst( CITNode );
} else if( next->opn.us == USOPN_CON ) {
AddConst( next );
}
GenOprTable[ op ]( typ1, typ2, op );
}
}
switch( opr ) {
case OPR_EQV:
case OPR_NEQV:
case OPR_OR:
case OPR_AND:
case OPR_NOT:
if( _IsTypeInteger( typ1 ) ) {
Extension( MD_LOGOPR_INTOPN );
}
break;
case OPR_EQ: // relational operators
case OPR_NE:
case OPR_LT:
case OPR_GE:
case OPR_LE:
case OPR_GT:
ResultType = FT_LOGICAL;
res_size = TypeSize( ResultType );
break;
case OPR_FLD:
case OPR_DPT:
// set result size to size of field
res_size = next->size;
FixFldNode();
break;
}
CITNode->size = res_size;
CITNode->typ = ResultType;
FixList();
}
}
void SFPrologue( void ) {
//====================
// Generate code for statement function prologue.
sym_id sym;
itnode *func_node;
itnode *arg_list;
sf_parm **parm;
StmtSw |= SS_SF_REFERENCED;
CkTypeDeclared();
SFSymId = CITNode->sym_ptr;
if( ( SFSymId->ns.typ == FT_CHAR ) && ( SFSymId->ns.xt.size == 0 ) ) {
Error( SF_ILL_CHAR_LEN );
} else if( SFSymId->ns.typ == FT_STRUCTURE ) {
Error( SF_ILL_TYPE );
}
GStartSF();
SFSymId->ns.flags = SY_USAGE | SY_TYPE | SY_SUBPROGRAM | SY_STMT_FUNC;
CITNode->flags = SFSymId->ns.flags;
func_node = CITNode;
AdvanceITPtr();
ReqOpenParen();
SFSymId->ns.si.sf.header = FMemAlloc( sizeof( sf_header ) );
SFSymId->ns.si.sf.header->ref_count = 1;
parm = &SFSymId->ns.si.sf.header->parm_list;
*parm = NULL;
if( RecNOpn() ) {
AdvanceITPtr();
} else {
for(;;) {
if( ReqName( NAME_SF_DUMMY ) ) {
sym = LkSym();
sym->ns.xflags |= SY_DEFINED;
CkTypeDeclared();
if( ( ( sym->ns.flags & SY_CLASS ) == SY_VARIABLE ) &&
( ( sym->ns.flags & SY_SUBSCRIPTED ) == 0 ) &&
( ( sym->ns.typ != FT_CHAR ) ||
( sym->ns.xt.size != 0 ) ) &&
( sym->ns.typ != FT_STRUCTURE ) ) {
if( sym->ns.flags & SY_SPECIAL_PARM ) {
Error( SF_DUPLICATE_DUMMY_PARM );
} else {
*parm = FMemAlloc( sizeof( sf_parm ) );
(*parm)->link = NULL;
(*parm)->actual = sym;
(*parm)->shadow = STShadow( sym );
parm = &((*parm)->link);
}
} else {
Error( SF_ILL_DUMMY_PARM );
}
}
AdvanceITPtr();
if( !RecComma() ) break;
}
}
ReqCloseParen();
ReqNOpn();
arg_list = func_node->link;
func_node->link = CITNode->link;
CITNode->link = NULL;
CITNode = func_node;
FreeITNodes( arg_list );
}
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();
}