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;
}
static void VarList( void ) {
//=========================
// Process one variable list in a DATA statement.
OPR last_opr;
OPR opr;
int do_level;
itnode *last_node;
do_level = 0;
last_opr = FindSlash( &last_node );
while( CITNode != last_node ) {
if( AError )
break;
if( RecTrmOpr() && ( CITNode != ITHead ) ) {
--do_level;
FinishImpDo();
} else if( StartImpDo() ) {
++do_level;
} else if( ReqName( NAME_VAR_OR_ARR ) ) {
InitVar = LkSym();
if( InitVar->u.ns.u1.s.typ == FT_STRUCTURE ) {
// make sure structure size is calculated - normally
// structure size is calculated by StructResolve() which
// is not called until the first executable statement
CalcStructSize( InitVar->u.ns.xt.sym_record );
}
CkFlags();
opr = CITNode->opr;
ProcDataExpr();
CITNode->opr = opr;
ListItem();
if( !RecTrmOpr() ) {
ReqComma();
}
} else {
AdvanceITPtr();
AError = true;
break;
}
}
if( AError ) {
while( do_level != 0 ) { // clean up hanging do entrys
TermDo();
--do_level;
}
} else {
CITNode->opr = last_opr;
ReqDiv();
}
}
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 );
}
static bool FormatIdentifier( void ) {
//====================================
if( RecComma() && RecNextOpr( OPR_EQU ) )
return false;
if( RecCloseParen() )
return false;
if( RecTrmOpr() )
return false;
ReqComma();
return true;
}
void ProcessList( void ) {
//=====================
// This procedure will process one 'thing' from the i/o list. A 'thing' is:
// 1) initializing an implied DO
// 2) finishing an implied DO
// 3) an i/o list item
if( RecTrmOpr() ) {
FinishImpDo();
if( !RecTrmOpr() ) {
ReqComma();
}
} else if( !StartImpDo() ) {
ProcIOExpr();
ListItem();
if( !RecTrmOpr() ) {
ReqComma();
}
}
}
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();
}
static void CkNameNoList( void ) {
//==============================
// Check that array/subprogram with no list is alright.
if( ( ASType & AST_IO ) && RecTrmOpr() && RecNextOpr( OPR_TRM ) ) {
if( ( CITNode->opn.us & USOPN_WHAT ) != USOPN_ARR ) {
ClassErr( SV_NO_LIST, CITNode->sym_ptr );
}
return;
}
if( ( !RecNextOpr( OPR_COM ) && !RecNextOpr( OPR_RBR ) ) ||
( !RecComma() && !RecFBr() ) ) {
ClassErr( SV_NO_LIST, CITNode->sym_ptr );
}
}
void CpWrite( void ) {
//=================
// Compile WRITE statement.
InitIO();
if( RecTrmOpr() && RecNOpn() ) {
AdvanceITPtr();
}
if( ReqOpenParen() ) {
KeywordList();
ReqCloseParen();
IOList();
}
ReqEOS();
FiniIO();
}
static void SubProg( void ) {
//=========================
// Make sure subprograms are used correctly.
unsigned_16 sp_type;
sp_type = CITNode->flags & SY_SUBPROG_TYPE;
if( ( sp_type == SY_REMOTE_BLOCK ) || ( sp_type == SY_PROGRAM ) ) {
IllName( CITNode->sym_ptr );
} else if( sp_type == SY_STMT_FUNC ) {
if( RecNWL() ) {
if( ASType & AST_ASF ) { // if defining s. f.
if( CITNode->sym_ptr == SFSymId ) {
Error( SR_TRIED_RECURSION ); // check recursion
}
}
} else {
if( ( ASType & AST_ASF ) == 0 ) { // if not defining s. f.
IllName( CITNode->sym_ptr );
}
}
} else if( sp_type == SY_SUBROUTINE ) {
if( RecNWL() ) {
if( ( StmtProc == PR_CALL ) && RecTrmOpr() ) {
if( ( CITNode->flags & SY_PS_ENTRY ) != 0 ) {
Extension( SR_TRIED_RECURSION );
}
} else {
IllName( CITNode->sym_ptr );
}
} else if( ( ASType & AST_CNA ) == 0 ) {
CkNameNoList();
} else if( ( CITNode->flags & SY_PS_ENTRY ) != 0 ) {
Extension( SR_TRIED_RECURSION );
}
} else if( sp_type == SY_FUNCTION ) {
if( RecNWL() && SubStrung() && (CITNode->typ == FT_CHAR) &&
(CITNode->flags & SY_PS_ENTRY) ) {
GetFunctionShadow();
} else if( !RecNWL() && !(ASType & AST_CNA) ) {
if( CITNode->flags & SY_PS_ENTRY ) {
GetFunctionShadow();
} else {
CkNameNoList();
}
} else if( ( CITNode->flags & SY_PS_ENTRY ) != 0 ) {
Extension( SR_TRIED_RECURSION );
} else if( CITNode->flags & SY_INTRINSIC ) {
if( CITNode->sym_ptr->ns.si.fi.index == IF_ISIZEOF ) {
ASType |= AST_ISIZEOF;
}
}
} else if( sp_type == SY_FN_OR_SUB ) {
if( RecNWL() ) { // if it's in a CALL statement
CITNode->flags |= SY_FUNCTION; // the class will already be
SetTypeUsage( SY_TYPE | SY_USAGE ); // SUBROUTINE and we won't
} else { // be in this part of the code
CkNameNoList();
}
}
}
