void FCPush( void ) {
//================
// Process PUSH F-Code.
sym_id sym;
sym = GetPtr();
if( TypeCmplx( sym->ns.typ ) ) {
PushComplex( sym );
} else {
XPush( SymAddr( sym ) );
}
}
void TDStmtFini( void ) {
//============================
// Target dependent statement finalization.
if( StmtProc == PR_ASNMNT ) {
if( TypeCmplx( ResultType ) ) {
EmitOp( FC_CMPLX_EXPR_DONE );
} else {
EmitOp( FC_EXPR_DONE );
}
}
if( StmtSw & SS_SF_REFERENCED ) {
EmitOp( FC_SF_REFERENCED );
}
EmitOp( FC_STMT_DONE );
}
static void Unary( TYPE typ, OPTR opr ) {
//=======================================
// Generate code for unary plus or unary minus.
PushOpn( CITNode->link );
if( opr == OPTR_SUB ) { // unary minus
if( TypeCmplx( typ ) ) {
EmitOp( FC_CUMINUS );
} else {
EmitOp( FC_UMINUS );
}
GenType( CITNode->link );
} else if( ( _IsTypeInteger( CITNode->link->typ ) ) &&
( CITNode->link->size < sizeof( intstar4 ) ) ) {
// convert INTEGER*1 or INTEGER*2 to INTEGER*4
EmitOp( FC_CONVERT );
DumpTypes( CITNode->link->typ, CITNode->link->size, FT_INTEGER, sizeof( intstar4 ) );
}
SetOpn( CITNode, USOPN_SAFE );
}
void FCSFCall( void ) {
//==================
// Call a statement function.
sym_id sf;
sym_id sf_arg;
sym_id tmp;
cg_type sf_type;
cg_name arg_list;
cg_name value;
cg_cmplx z;
obj_ptr curr_obj;
sf = GetPtr();
arg_list = NULL;
value = NULL;
sf_type = 0;
for(;;) {
sf_arg = GetPtr();
if( sf_arg == NULL ) break;
if( sf_arg->u.ns.u1.s.typ == FT_CHAR ) {
value = Concat( 1, CGFEName( sf_arg, TY_CHAR ) );
} else {
sf_type = F772CGType( sf_arg );
if( TypeCmplx( sf_arg->u.ns.u1.s.typ ) ) {
XPopCmplx( &z, sf_type );
sf_type = CmplxBaseType( sf_type );
value = ImagPtr( SymAddr( sf_arg ), sf_type );
CGTrash( CGAssign( value, z.imagpart, sf_type ) );
value = CGFEName( sf_arg, sf_type );
value = CGAssign( value, z.realpart, sf_type );
} else {
value = CGFEName( sf_arg, sf_type );
value = CGAssign( value, XPopValue( sf_type ), sf_type );
}
}
if( arg_list == NULL ) {
arg_list = value;
} else {
arg_list = CGBinary( O_COMMA, arg_list, value, TY_DEFAULT );
}
}
if( sf->u.ns.u1.s.typ == FT_CHAR ) {
tmp = GetPtr();
value = CGUnary( O_POINTS, CGFEName( tmp, TY_CHAR ), TY_CHAR );
value = CGAssign( CGFEName( sf, TY_CHAR ), value, TY_CHAR );
if( arg_list == NULL ) {
arg_list = value;
} else {
arg_list = CGBinary( O_COMMA, arg_list, value, TY_DEFAULT );
}
value = CGFEName( tmp, TY_CHAR );
} else {
sf_type = F772CGType( sf );
if( !(OZOpts & OZOPT_O_INLINE) ) {
value = CGUnary( O_POINTS, CGFEName( sf, sf_type ), sf_type );
}
}
if( OZOpts & OZOPT_O_INLINE ) {
if( arg_list != NULL ) {
CGTrash( arg_list );
}
curr_obj = FCodeSeek( sf->u.ns.si.sf.u.sequence );
GetObjPtr();
FCodeSequence();
FCodeSeek( curr_obj );
if( sf->u.ns.u1.s.typ == FT_CHAR ) {
CGTrash( XPop() );
XPush( value );
} else if( TypeCmplx( sf->u.ns.u1.s.typ ) ) {
XPopCmplx( &z, sf_type );
sf_type = CmplxBaseType( sf_type );
XPush( TmpVal( MkTmp( z.imagpart, sf_type ), sf_type ) );
XPush( TmpVal( MkTmp( z.realpart, sf_type ), sf_type ) );
} else {
XPush( TmpVal( MkTmp( XPopValue( sf_type ), sf_type ), sf_type ) );
}
} else {
value = CGWarp( arg_list, GetLabel( sf->u.ns.si.sf.u.location ), value );
// consider: y = f( a, f( b, c, d ), e )
// make sure that inner reference to f gets evaluated before we assign
// arguments for outer reference
value = CGEval( value );
if( TypeCmplx( sf->u.ns.u1.s.typ ) ) {
SplitCmplx( TmpPtr( MkTmp( value, sf_type ), sf_type ), sf_type );
} else {
XPush( value );
}
RefStmtFunc( sf );
}
}
cg_name SymIndex( sym_id sym, cg_name i ) {
//=========================================
// Get address of symbol plus an index.
// Merges offset of symbols in common or equivalence with index so that
// we don't get two run-time calls for huge pointer arithmetic.
sym_id leader;
cg_name addr;
signed_32 offset;
com_eq *ce_ext;
cg_type p_type;
bool data_reference;
data_reference = TRUE;
if( ( sym->ns.flags & SY_CLASS ) == SY_SUBPROGRAM ) {
if( ( sym->ns.flags & SY_SUBPROG_TYPE ) == SY_STMT_FUNC ) {
addr = CGFEName( sym, F772CGType( sym ) );
} else {
addr = CGFEName( sym, TY_CODE_PTR );
if( sym->ns.flags & SY_SUB_PARM ) {
addr = CGUnary( O_POINTS, addr, TY_CODE_PTR );
}
data_reference = FALSE;
}
} else if( sym->ns.flags & SY_PS_ENTRY ) {
// it's the shadow symbol for function return value
if( CommonEntry == NULL ) {
if( sym->ns.typ == FT_CHAR ) {
if( Options & OPT_DESCRIPTOR ) {
addr = CGFEName( ReturnValue, F772CGType( sym ) );
addr = CGUnary( O_POINTS, addr, TY_POINTER );
} else {
addr = SubAltSCB( sym->ns.si.ms.sym );
}
} else {
addr = CGFEName( ReturnValue, F772CGType( sym ) );
}
} else {
if( (sym->ns.typ == FT_CHAR) && !(Options & OPT_DESCRIPTOR) ) {
addr = SubAltSCB( CommonEntry );
} else {
addr = CGUnary( O_POINTS, CGFEName( ReturnValue, TY_POINTER ),
TY_POINTER );
}
}
} else if( sym->ns.flags & SY_SUB_PARM ) {
// subprogram argument
if( sym->ns.flags & SY_SUBSCRIPTED ) {
p_type = ArrayPtrType( sym );
if( sym->ns.typ == FT_CHAR ) {
addr = CGUnary( O_POINTS, CGFEName( sym, p_type ), p_type );
if( !(sym->ns.flags & SY_VALUE_PARM) ) {
if( Options & OPT_DESCRIPTOR ) {
addr = SCBPointer( addr );
}
}
} else {
addr = CGUnary( O_POINTS, CGFEName( sym, p_type ), p_type );
}
} else {
p_type = TY_POINTER;
if( sym->ns.typ == FT_CHAR ) {
if( SCBRequired( sym ) ) {
addr = VarAltSCB( sym );
} else {
addr = CGUnary( O_POINTS, CGFEName( sym, p_type ), p_type );
}
} else if( sym->ns.flags & SY_VALUE_PARM ) {
p_type = F772CGType( sym );
if( TypeCmplx( sym->ns.typ ) ) {
p_type = CmplxBaseType( p_type );
addr = CGFEName( sym, p_type );
XPush( CGUnary( O_POINTS,
CGFEName( FindArgShadow( sym ), p_type ),
p_type ) );
addr = CGUnary( O_POINTS, addr, p_type );
} else {
addr = CGFEName( sym, p_type );
}
} else {
addr = CGUnary( O_POINTS, CGFEName( sym, p_type ), p_type );
}
}
} else if( sym->ns.flags & SY_IN_EQUIV ) {
leader = sym;
offset = 0;
for(;;) {
if( leader->ns.si.va.vi.ec_ext->ec_flags & LEADER ) break;
offset += leader->ns.si.va.vi.ec_ext->offset;
leader = leader->ns.si.va.vi.ec_ext->link_eqv;
}
if( leader->ns.si.va.vi.ec_ext->ec_flags & MEMBER_IN_COMMON ) {
addr = CGFEName( leader->ns.si.va.vi.ec_ext->com_blk,
F772CGType( sym ) );
offset += leader->ns.si.va.vi.ec_ext->offset;
} else {
sym_id shadow;
shadow = FindEqSetShadow( leader );
if( shadow != NULL ) {
addr = CGFEName( shadow, shadow->ns.si.ms.cg_typ );
offset -= leader->ns.si.va.vi.ec_ext->low;
} else if( (leader->ns.typ == FT_CHAR) &&
!(leader->ns.flags & SY_SUBSCRIPTED) ) {
addr = CGBackName( leader->ns.si.va.bck_hdl, F772CGType( sym ) );
} else {
addr = CGFEName( leader, F772CGType( sym ) );
}
}
if( i != NULL ) {
i = CGBinary( O_PLUS, i, CGInteger( offset, TY_INT_4 ), TY_INT_4 );
} else {
i = CGInteger( offset, TY_INT_4 );
}
addr = CGBinary( O_PLUS, addr, i, SymPtrType( sym ) );
if( (sym->ns.typ == FT_CHAR) && !(sym->ns.flags & SY_SUBSCRIPTED) ) {
// tell code generator where storage pointed to by SCB is located
addr = CGBinary( O_COMMA, addr,
CGFEName( sym, F772CGType( sym ) ), TY_DEFAULT );
}
i = NULL;
} else if( ( sym->ns.typ == FT_CHAR ) &&
( ( sym->ns.flags & SY_SUBSCRIPTED ) == 0 ) ) {
// character variable, address of scb
addr = CGFEName( sym, F772CGType( sym ) );
} else if( sym->ns.flags & SY_IN_COMMON ) {
ce_ext = sym->ns.si.va.vi.ec_ext;
if( i != NULL ) {
i = CGBinary( O_PLUS, i, CGInteger( ce_ext->offset, TY_INT_4 ),
TY_INT_4 );
} else {
i = CGInteger( ce_ext->offset, TY_INT_4 );
}
addr = CGBinary( O_PLUS, CGFEName( ce_ext->com_blk, F772CGType( sym ) ),
i, SymPtrType( sym ) );
i = NULL;
} else {
addr = CGFEName( sym, F772CGType( sym ) );
if( ( sym->ns.flags & SY_SUBSCRIPTED ) && _Allocatable( sym ) ) {
addr = CGUnary( O_POINTS, addr, ArrayPtrType( sym ) );
}
}
if( i != NULL ) {
addr = CGBinary( O_PLUS, addr, i, SymPtrType( sym ) );
}
if( ( OZOpts & OZOPT_O_VOLATILE ) && data_reference &&
( ( sym->ns.typ >= FT_REAL ) && ( sym->ns.typ <= FT_XCOMPLEX ) ) ) {
addr = CGVolatile( addr );
} else if( sym->ns.xflags & SY_VOLATILE ) {
addr = CGVolatile( addr );
}
return( addr );
}
static void Binary( TYPE typ1, TYPE typ2, OPTR opr ) {
//====================================================
// Generate code for binary operations.
bool flip;
bool associative;
FCODE op_code;
associative = FALSE;
if( ( opr == OPTR_ADD ) || ( opr == OPTR_MUL ) ) {
associative = TRUE;
}
flip = FALSE;
if( ( ( CITNode->opn.us & USOPN_WHERE ) == USOPN_SAFE ) &&
( ( CITNode->link->opn.us & USOPN_WHERE ) != USOPN_SAFE ) ) {
flip = TRUE;
}
op_code = opr - OPTR_FIRST_ARITHOP;
PushOpn( CITNode->link );
PushOpn( CITNode );
if( TypeCmplx( typ1 ) && TypeCmplx( typ2 ) ) {
op_code += FC_CC_BINOPS;
if( flip && !associative ) {
EmitOp( FC_CMPLX_FLIP );
}
} else if( TypeCmplx( typ1 ) ) {
if( flip ) {
if( associative ) {
op_code += FC_XC_BINOPS;
} else {
EmitOp( FC_XC_FLIP );
op_code += FC_CX_BINOPS;
}
} else {
op_code += FC_CX_BINOPS;
}
} else if( TypeCmplx( typ2 ) ) {
if( flip ) {
if( associative ) {
op_code += FC_CX_BINOPS;
} else {
EmitOp( FC_CX_FLIP );
op_code += FC_XC_BINOPS;
}
} else {
op_code += FC_XC_BINOPS;
}
} else {
op_code += FC_BINOPS;
if( flip && !associative ) {
EmitOp( FC_FLIP );
}
}
EmitOp( op_code );
if( flip && associative ) {
GenTypes( CITNode->link, CITNode );
} else {
GenTypes( CITNode, CITNode->link );
}
}
void RelOp( TYPE typ1, TYPE typ2, OPTR optr ) {
//================================================
// Generate code for a relational operator.
bool flip;
bool associative;
bool char_1_cmp;
uint i;
uint j;
OPR opr_code;
FCODE op_code;
optr = optr;
// must check for "flip" before we call "CharLength" since they may
// call "PushOpn"
flip = FALSE;
if( ( ( CITNode->opn.us & USOPN_WHERE ) == USOPN_SAFE ) &&
( ( CITNode->link->opn.us & USOPN_WHERE ) != USOPN_SAFE ) ) {
flip = TRUE;
}
// must do "CITNode->link" first to get operands in the right order
i = CharLength( CITNode->link );
j = CharLength( CITNode );
opr_code = CITNode->link->opr;
if( ( opr_code == OPR_EQ ) || ( opr_code == OPR_NE ) ) {
char_1_cmp = OptimalChSize( i ) && OptimalChSize( j ) && ( i == j );
associative = TRUE;
} else {
char_1_cmp = (i == 1 ) && ( j == 1 );
associative = FALSE;
}
PushOpn( CITNode->link );
PushOpn( CITNode );
op_code = opr_code - OPR_FIRST_RELOP;
if( TypeCmplx( typ1 ) && TypeCmplx( typ2 ) ) {
op_code += FC_CC_RELOPS;
} else if( TypeCmplx( typ1 ) ) {
if( flip ) {
op_code += FC_XC_RELOPS;
} else {
op_code += FC_CX_RELOPS;
}
} else if( TypeCmplx( typ2 ) ) {
if( flip ) {
op_code += FC_CX_RELOPS;
} else {
op_code += FC_XC_RELOPS;
}
} else {
if( flip && !associative ) {
EmitOp( FC_FLIP );
}
if( typ1 == TY_CHAR ) {
if( char_1_cmp ) {
op_code += FC_CHAR_1_RELOPS;
} else {
op_code += FC_CHAR_RELOPS;
}
} else {
op_code += FC_RELOPS;
}
}
EmitOp( op_code );
if( char_1_cmp ) {
if( associative ) {
DumpType( MapTypes( TY_INTEGER, i ), i );
} else {
// Assert: comparing CHARACTER*1 with LT, LE, GT, or GE
// Consider: CHARACTER A/'a'/
// IF( A .lt. CHAR(159) ) PRINT *, 'OK'
// we must generate an unsigned comparison
DumpType( MapTypes( TY_LOGICAL, i ), i );
}
if( flip && associative ) {
GenChar1Op( CITNode->link );
GenChar1Op( CITNode );
} else {
GenChar1Op( CITNode );
GenChar1Op( CITNode->link );
}
} else if( typ1 != TY_CHAR ) {
if( flip && associative ) {
GenTypes( CITNode->link, CITNode );
} else {
GenTypes( CITNode, CITNode->link );
}
}
}
