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();
}
}
void CpRead( void ) {
//================
// Compile READ statement.
itnode *cit;
Remember.read = true;
InitIO();
cit = CITNode;
AdvanceITPtr();
if( RecOpenParen() && ReadKWList() ) {
KeywordList();
ReqCloseParen();
} else {
CITNode = cit;
Form();
if( !RecEOS() ) {
ReqComma();
}
}
if( !Remember.end_equals ) {
GNullEofStmt();
}
IOList();
ReqEOS();
FiniIO();
}
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 );
}
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 CpEntry( void )
{
entry_pt *entry;
bool in_subr;
sym_id sym;
if( ( ProgSw & PS_IN_SUBPROGRAM ) == 0 ) {
StmtErr( SR_ILL_IN_PROG );
}
if( !EmptyCSList() ) {
Error( EY_NOT_IN_CS );
}
if( ReqName( NAME_FUNCTION ) ) {
in_subr = (SubProgId->u.ns.flags & SY_SUBPROG_TYPE) == SY_SUBROUTINE;
sym = LkSym();
if( ( sym->u.ns.flags & (SY_USAGE|SY_SUB_PARM|SY_IN_EC|SY_SAVED) ) ||
( in_subr && (sym->u.ns.flags & SY_TYPE) ) ) {
IllName( sym );
} else {
sym->u.ns.u1.s.typ = CITNode->typ;
sym->u.ns.flags &= SY_TYPE;
if( in_subr ) {
sym->u.ns.flags |= SY_USAGE | SY_SUBPROGRAM | SY_SENTRY |
SY_SUBROUTINE | SY_REFERENCED;
} else {
sym->u.ns.flags |= SY_USAGE | SY_SUBPROGRAM | SY_SENTRY |
SY_FUNCTION;
}
STFnShadow( sym );
entry = AddEntryPt( sym );
AdvanceITPtr();
if( Options & OPT_TRACE ) {
GSetSrcLine();
}
if( RecOpenParen() ) {
ParmList( in_subr, entry );
ReqCloseParen();
ReqNOpn();
AdvanceITPtr();
}
BIStartRBorEP( sym );
ReqEOS();
}
}
SgmtSw &= ~SG_PROLOG_DONE; // indicate we need prologue
}
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();
}
}
void CpSubroutine( void )
{
entry_pt *entry;
CkSubEnd();
ProgSw |= PS_IN_SUBPROGRAM;
if( ReqName( NAME_SUBROUTINE ) ) {
entry = SubProgName( FT_NO_TYPE, SY_USAGE | SY_SUBPROGRAM | SY_PENTRY |
SY_SUBROUTINE | SY_REFERENCED, 0, true );
if( RecOpenParen() ) {
ParmList( true, entry );
ReqCloseParen();
ReqNOpn();
AdvanceITPtr();
}
ReqEOS();
} else {
// We still want to start a subprogram even though there is no name.
SubProgId = LkProgram(); // use default name
GSegLabel();
}
BIStartSubroutine();
}
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();
}
