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();
}
}
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();
}
}
}
}
static void ConList( void ) {
//=========================
// Collect constants for data initialization.
OPR opr;
itnode *last_node;
opr = FindSlash( &last_node );
for(;;) {
if( RecNextOpr( OPR_MUL ) ) {
ProcDataRepExpr();
if( ITIntValue( CITNode ) <= 0 ) {
Error( DA_BAD_RPT_SPEC );
}
AddConst( CITNode );
AdvanceITPtr();
}
if( !HexConst() ) {
GetSConst();
AddConst( CITNode );
}
AdvanceITPtr();
if( CITNode == last_node )
break;
ReqComma();
if( AError ) {
break;
}
}
CITNode->opr = opr;
ReqDiv();
}
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 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 KeywordList( void ) {
//===========================
bool morelist;
if( RecNextOpr( OPR_EQU ) ) {
morelist = true;
} else {
if( Permission( IO_UNIT ) ) {
Unit();
AdvanceITPtr();
} else {
NextComma();
}
if( FormatIdentifier() ) {
if( Permission( IO_FMT ) ) {
FormatIdd();
AdvanceITPtr();
} else {
NextComma();
}
}
morelist = RecComma();
}
if( morelist ) {
for(;;) {
GetItem();
if( !RecComma() ) break;
}
}
CheckList(); // check that list had necessities ( unit )
// also remember if end= is specified
}
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 );
}
}
bool ReqNextOpr( OPR operator, int error ) {
//==============================================
if( RecNextOpr( operator ) )
return( true );
AdvError( error );
return( false );
}
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();
}
}
static bool CheckColon(void) {
//============================
if( RecNextOpr( OPR_COL ) ) {
CITNode->opr = OPR_COL;
return( true );
}
return( false );
}
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();
}
}
static bool FormatIdentifier( void ) {
//====================================
if( RecComma() && RecNextOpr( OPR_EQU ) )
return false;
if( RecCloseParen() )
return false;
if( RecTrmOpr() )
return false;
ReqComma();
return true;
}
void CpLogIf(void) {
//=================
// Process a logical IF statement.
label_id if_skip;
if_skip = NextLabel();
CSCond( if_skip );
if( RecKeyWord( "THEN" ) &&
( RecNextOpr( OPR_TRM ) || RecNextOpr( OPR_COL ) ) ) {
AddCSNode( CS_IF );
CSHead->branch = if_skip;
CSHead->bottom = NextLabel();
CITNode->opn.ds = DSOPN_PHI; // not part of the block label
BlockLabel();
CtrlFlgs |= CF_BAD_DO_ENDING;
} else {
Recurse();
GLabel( if_skip );
FreeLabel( if_skip );
}
}
static void CkFieldNoList( void ) {
//===============================
// Check that array field with no list is alright.
itnode *opr_node;
// find the node that contains the structured symbol
opr_node = FieldNode;
while( opr_node->value.sc.struct_chain != NULL ) {
opr_node = opr_node->value.sc.struct_chain;
}
if( ( ASType & AST_IO ) && ( opr_node->opr == OPR_TRM ) &&
RecNextOpr( OPR_TRM ) ) {
if( ( CITNode->opn.us & USOPN_WHAT ) != USOPN_ARR ) {
KnownClassErr( SV_NO_LIST, NAME_ARRAY );
}
return;
}
if( ( !RecNextOpr( OPR_COM ) && !RecNextOpr( OPR_RBR ) ) ||
( ( opr_node->opr != OPR_COM ) && ( opr_node->opr != OPR_FBR ) ) ) {
KnownClassErr( SV_NO_LIST, NAME_ARRAY );
}
}
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();
}
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 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 DSName( void ) {
//================
// Downscan a name.
sym_id sym_ptr;
CITNode->opn.us = USOPN_NNL;
if( RecNextOpr( OPR_LBR ) ) {
CITNode->link->opr = OPR_FBR;
CITNode->opn.us = USOPN_NWL;
}
if( ( FieldNode != NULL ) &&
( ( CITNode->opr == OPR_FLD ) || ( CITNode->opr == OPR_DPT ) ) ) {
if( FieldNode->opn.us & USOPN_FLD ) {
LkField( FieldNode->sym_ptr->fd.xt.sym_record );
} else {
LkField( FieldNode->sym_ptr->ns.xt.sym_record );
}
CITNode->opn.us |= USOPN_FLD;
if( CITNode->sym_ptr != NULL ) { // make sure field name exists
if( CITNode->sym_ptr->fd.dim_ext != NULL ) { // field is an array
if( ( CITNode->opn.us & USOPN_WHAT ) != USOPN_NWL ) {
CITNode->opn.us &= ~USOPN_WHAT;
CITNode->opn.us |= USOPN_ARR;
CkFieldNoList();
}
} else if( ( CITNode->opn.us & USOPN_WHAT ) == USOPN_NWL ) {
// field better be character and substrung
if( ( CITNode->sym_ptr->fd.typ != FT_CHAR ) || !SubStrung() ) {
AdvError( PC_SURP_PAREN );
}
}
// setup FieldNode for the next field lookup
if( CITNode->sym_ptr->fd.typ == FT_STRUCTURE ) {
// chain fields for CkFieldNoList()
CITNode->value.sc.struct_chain = FieldNode;
FieldNode = CITNode; // must come after LkField()
} else {
// this field is not structured so go back to the previous
// FieldNode
// consider: STRUCTURE /S1/
// INTEGER J
// END STRUCTURE
// STRUCTURE /S2/
// RECORD /S1/ A(10)
// END STRUCTURE
// RECORD /S2/ X
// RECORD /S1/ I
// X%A(I%J)%K
// when we are done with I%J, set FieldNode back to "A" so we
// can compute offset of "K" (see ChkStructName())
//
// we must go back as many as necessary, i.e. a(b.c.d.e).f
while( (FieldNode->opr==OPR_DPT) || (FieldNode->opr==OPR_FLD) ){
FieldNode = FieldNode->value.sc.struct_chain;
}
FieldNode = FieldNode->value.sc.struct_chain;
}
}
return;
}
if( ASType & AST_ISIZEOF ) {
// Case 1: Case 2:
// STRUCTURE /XXX/ STRUCTURE /XXX/
// INTEGER I INTEGER I
// END STRUCTURE END STRUCTURE
// INTEGER XXX PRINT *, ISIZEOF( XXX )
// PRINT *, ISIZEOF( XXX )
// Case 1:
// We want to issue an "unreferenced" error for XXX so don't set
// SY_REFERENCED bit in symbol table.
// Case 2:
// We don't want to issue "undeclared type" error for XXX if XXX
// did not appear in a type declaration statement.
sym_id sd;
ASType &= ~AST_ISIZEOF;
sd = FindStruct( CITNode->opnd, CITNode->opnd_size );
if( sd != NULL ) {
CITNode->opn.us = USOPN_CON;
CITNode->typ = FT_STRUCTURE;
CITNode->value.intstar4 = sd->sd.size;
return;
}
}
sym_ptr = LkSym();
if( ( ASType & AST_DEXP ) && ( sym_ptr != InitVar ) &&
( ( sym_ptr->ns.flags & SY_CLASS ) != SY_PARAMETER ) &&
( ( ( sym_ptr->ns.flags & SY_CLASS ) != SY_VARIABLE ) ||
( ( sym_ptr->ns.flags & SY_SPECIAL_PARM ) == 0 ) ) ) {
NameErr( DA_BAD_VAR_IN_EXPR, sym_ptr );
}
if( ClassIs( SY_VARIABLE ) ) {
ChkStructName();
if( Subscripted() ) { // if dimensioned
if( ASType & AST_DIM ) {
ClassErr( DM_SYM_PARM, sym_ptr );
} else if( !RecNWL() ) {
CITNode->opn.us = USOPN_ARR; // array without subscript list
CkNameNoList();
}
SetTypeUsage( SY_TYPE | SY_USAGE );
} else if( RecNWL() ) { // if name with list, not dimensioned
if( ASType & AST_DIM ) {
IllName( sym_ptr );
} else if( (CITNode->typ == FT_CHAR) && SubStrung() ) {
SetTypeUsage( SY_TYPE | SY_USAGE );
} else {
ScanningFunction();
}
} else {
if( ASType & AST_DIM ) {
CITNode->flags |= SY_IN_DIMEXPR;
SetTypeUsage( SY_USAGE );
} else {
SetTypeUsage( SY_TYPE | SY_USAGE );
}
}
} else if( ClassIs( SY_SUBPROGRAM ) ) {
ChkStructName();
if( ASType & AST_DIM ) {
ClassErr( DM_SYM_PARM, sym_ptr );
} else {
SubProg();
}
} else { // if( ClassIs( SY_PARAMETER ) ) {
if( RecNWL() ) {
IllName( sym_ptr );
} else {
CITNode->opn.us = USOPN_CON;
CITNode->sym_ptr = sym_ptr->ns.si.pc.value;
if( CITNode->typ == FT_CHAR ) {
if( StmtSw & SY_DATA_INIT ) {
CITNode->sym_ptr->lt.flags |= LT_DATA_STMT;
} else {
CITNode->sym_ptr->lt.flags |= LT_EXEC_STMT;
}
CITNode->value.cstring.strptr = (char *)&CITNode->sym_ptr->lt.value;
CITNode->value.cstring.len = CITNode->sym_ptr->lt.length;
} else {
memcpy( &CITNode->value, &CITNode->sym_ptr->cn.value,
CITNode->size );
}
}
}
BIOutSymbol( sym_ptr );
if( ( sym_ptr->ns.flags & SY_REFERENCED ) == 0 ) {
if( ASType & AST_ASF ) {
if( sym_ptr != SFSymId ) {
sym_ptr->ns.flags |= SY_REFERENCED;
}
} else if( ( ASType & AST_DEXP ) == 0 ) {
if( SgmtSw & SG_SYMTAB_RESOLVED ) {
sym_ptr->ns.flags |= SY_REFERENCED;
} else if( ASType & ( AST_DIM | AST_CEX | AST_DIEXP ) ) {
sym_ptr->ns.flags |= SY_REFERENCED;
}
}
}
}
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();
}