static bool UnaryMul( TYPE typ1, TYPE typ2 ) {
//============================================
if( typ1 > FT_EXTENDED )
return( FALSE );
if( !_IsTypeInteger( typ2 ) )
return( FALSE );
if( CITNode->link->opn.us != USOPN_CON )
return( FALSE );
if( ITIntValue( CITNode->link ) < 0 )
return( FALSE );
if( ITIntValue( CITNode->link ) > 8 )
return( FALSE );
return( TRUE );
}
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();
}
static void ExpOp( TYPE typ1, TYPE typ2, OPTR op ) {
//======================================================
op = op;
if( !_IsTypeInteger( typ2 ) ) {
Convert();
GenExp( ResultType );
} else {
CnvTo( CITNode, ResultType, TypeSize( ResultType ) );
ExpI( typ1, &CITNode->value, ITIntValue( CITNode->link ) );
}
}
static intstar4 GetIntValue( itnode *node ) {
//===========================================
if( node->typ == FT_REAL ) {
return( node->value.single );
} else if( node->typ == FT_DOUBLE ) {
return( node->value.dble );
} else if( node->typ == FT_EXTENDED ) {
return( node->value.extended );
} else {
return( ITIntValue( node ) );
}
}
static int SameScripts( itnode *op1, itnode *op2 ) {
//=======================================================
if( !SimpleScript( op1 ) ) return( 0 );
if( (op1->opn.us & USOPN_WHAT) == USOPN_NONE ) {
if( (op2->opn.us & USOPN_WHAT) == USOPN_CON ) {
return( ITIntValue( op2 ) );
} else {
return( 0 );
}
}
if( (op1->opn.us & USOPN_WHAT) != (op2->opn.us & USOPN_WHAT) ) {
return( 0 );
}
if( (op1->opn.us & USOPN_WHAT) == USOPN_NNL ) {
if( op1->sym_ptr == op2->sym_ptr ) {
return( 1 );
}
} else if( (op1->opn.us & USOPN_WHAT) == USOPN_CON ) {
return( ITIntValue( op2 ) - ITIntValue( op1 ) + 1 );
}
return( 0 );
}
void ExpOp( TYPE typ1, TYPE typ2, OPTR opr ) {
//===============================================
// Generate code to perform exponentiation.
if( UnaryMul( typ1, typ2 ) ) {
PushOpn( CITNode );
EmitOp( FC_UNARY_MUL );
GenType( CITNode );
OutU16( ITIntValue( CITNode->link ) );
SetOpn( CITNode, USOPN_SAFE );
} else {
BinOp( typ1, typ2, opr );
}
}
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();
}