static cg_name CharArrLength( sym_id sym ) {
//==========================================
// Get element size for character*(*) arrays.
if( sym->u.ns.flags & SY_VALUE_PARM ) {
return( CGInteger( 0, TY_INTEGER ) );
} else if( Options & OPT_DESCRIPTOR ) {
return( SCBLength( CGUnary( O_POINTS, CGFEName( sym, TY_POINTER ), TY_POINTER ) ) );
} else {
return( CGUnary( O_POINTS, CGFEName( FindArgShadow( sym ), TY_INTEGER ), TY_INTEGER ) );
}
}
void SplitCmplx( cg_name cmplx_addr, cg_type typ ) {
//=====================================================
// Split real and imaginary parts of complex number.
cg_name cmplx_1;
cg_name cmplx_2;
typ = CmplxBaseType( typ );
CloneCGName( cmplx_addr, &cmplx_1, &cmplx_2 );
XPush( CGUnary( O_POINTS, ImagPtr( cmplx_1, typ ), typ ) );
XPush( CGUnary( O_POINTS, cmplx_2, typ ) );
}
void FCUMinusCmplx( void ) {
//=======================
// Unary minus (-) F-Code processor for complex numbers.
cg_cmplx op;
cg_type typ;
typ = GetType( GetU16() );
XPopCmplx( &op, typ );
typ = CmplxBaseType( typ );
XPush( CGUnary( O_UMINUS, op.imagpart, typ ) );
XPush( CGUnary( O_UMINUS, op.realpart, typ ) );
}
static void ChkIOErr( cg_name io_stat ) {
//===========================================
// Check for i/o errors.
label_handle eq_label;
io_stat = CGUnary( O_POINTS, io_stat, TY_INTEGER );
if( ( EndEqLabel != 0 ) && ( ErrEqLabel != 0 ) ) {
eq_label = BENewLabel();
CG3WayControl( io_stat, GetLabel( EndEqLabel ), eq_label,
GetLabel( ErrEqLabel ) );
CGControl( O_LABEL, NULL, eq_label );
BEFiniLabel( eq_label );
} else if( EndEqLabel != 0 ) {
CGControl( O_IF_TRUE,
CGCompare( O_LT, io_stat, CGInteger( 0, TY_INTEGER ),
TY_INTEGER ),
GetLabel( EndEqLabel ) );
} else if( ErrEqLabel != 0 ) {
CGControl( O_IF_TRUE,
CGCompare( O_NE, io_stat, CGInteger( 0, TY_INTEGER ),
TY_INTEGER ),
GetLabel( ErrEqLabel ) );
} else if( IOStatSpecified ) {
IOSLabel = BENewLabel();
CGControl( O_IF_TRUE,
CGCompare( O_NE, io_stat, CGInteger( 0, TY_INTEGER ),
TY_INTEGER ),
IOSLabel );
} else {
CGDone( io_stat );
}
}
static void DbSubscript( sym_id arr ) {
//=========================================
// Generate call to debugging subscript routine.
act_dim_list *dim_ptr;
int dims_no;
int i;
call_handle call;
cg_name offset;
cg_name subscripts[MAX_DIM];
dim_ptr = arr->u.ns.si.va.u.dim_ext;
dims_no = _DimCount( dim_ptr->dim_flags );
call = InitCall( RT_SUBSCRIPT );
for( i = 0; i < dims_no; ++i ) {
subscripts[ i ] = GetTypedValue();
}
for( i = 1; i <= dims_no; ++i ) {
CGAddParm( call, subscripts[ dims_no - i ], TY_INT_4 );
}
CGAddParm( call, GetAdv( arr ), TY_LOCAL_POINTER );
CGAddParm( call, CGInteger( _DimCount( dim_ptr->dim_flags ), TY_INTEGER ), TY_INTEGER );
offset = CGUnary( O_POINTS, CGCall( call ), TY_INT_4 );
Index( arr, offset );
}
cg_name SCBLength( cg_name scb ) {
//================================
// Get length from SCB.
return( CGUnary( O_POINTS, SCBLenAddr( scb ), TY_UNSIGNED ) );
}
cg_name SymValue( sym_id sym ) {
//==============================
// Generate value of a symbol.
return( CGUnary( O_POINTS, SymAddr( sym ), F772CGType( sym ) ) );
}
cg_name SCBPointer( cg_name scb ) {
//=================================
// Get pointer from SCB.
return( CGUnary( O_POINTS, SCBPtrAddr( scb ), TY_GLOBAL_POINTER ) );
}
static cg_name HiBound( sym_id arr, int ss_offset ) {
//====================================================
// Get hi bound from ADV.
ss_offset = BETypeLength( TY_ADV_LO ) * ( ss_offset + 1 ) +
BETypeLength( TY_ADV_HI ) * ss_offset;
return( CGUnary( O_POINTS, StructRef( GetAdv( arr ), ss_offset ), TY_ADV_HI ) );
}
void FCConjg( void ) {
//=================
cg_cmplx z;
cg_type typ;
typ = GetType( GetU16() );
XPopCmplx( &z, typ );
XPush( CGUnary( O_UMINUS, z.imagpart, CmplxBaseType( typ ) ) );
XPush( z.realpart );
}
cg_name CgOffsetExpr( // MAKE OFFSET EXPRESSION
cg_name expr, // - lhs expression
target_offset_t offset, // - offset
cg_type type ) // - resultant type
{
if( offset == 0 ) {
expr = CGUnary( O_CONVERT, expr, type );
} else {
expr = CGBinary( O_PLUS, expr, CgOffset( offset ), type );
}
return expr;
}
cg_name XPopValue( cg_type typ ) {
//================================
// Pop a CG-name from the stack (its value).
cg_name opn;
opn = XPop();
if( TypePointer( CGType( opn ) ) ) {
opn = CGUnary( O_POINTS, opn, typ );
}
return( opn );
}
void FCImag( void ) {
//================
cg_name opn;
cg_type typ;
typ = CmplxBaseType( GetType( GetU16() ) );
opn = XPop();
if( TypePointer( CGType( opn ) ) ) {
XPush( CGUnary( O_POINTS, ImagPtr( opn, typ ), typ ) );
} else {
CGTrash( opn );
}
}
void FCFmtAssign( void ) {
//=====================
// Set FORMAT string for:
// ASSIGN 10 TO I
// PRINT I, ...
// 10 FORMAT( ... )
call_handle handle;
handle = InitCall( RT_SET_FMT );
CGAddParm( handle, CGUnary( O_POINTS, SymAddr( GetPtr() ), TY_POINTER ), TY_POINTER );
CGDone( CGCall( handle ) );
}
cg_name GetTypedValue( void ) {
//=======================
// Pop a CG-name from the stack (its value).
cg_name opn;
cg_type typ;
opn = XPop();
typ = GetType( GetU16() );
if( TypePointer( CGType( opn ) ) ) {
opn = CGUnary( O_POINTS, opn, typ );
}
return( opn );
}
void FCAdvFillHi( void ) {
//=====================
// Fill hi bound of a dimension (actually computes # of elements in dimension).
sym_id arr;
act_dim_list *dim_ptr;
uint lo_size;
uint hi_size;
int hi_offset;
int ss;
cg_name num_elts;
cg_name hi;
cg_name adv;
call_handle call;
arr = GetPtr();
dim_ptr = arr->u.ns.si.va.u.dim_ext;
adv = GetAdv( arr );
hi_size = BETypeLength( TY_ADV_HI );
lo_size = BETypeLength( TY_ADV_LO );
ss = GetU16();
hi = GetTypedValue();
if( CGOpts & CGOPT_DI_CV ) {
hi_offset = _DimCount( dim_ptr->dim_flags ) * BETypeLength( TY_ADV_ENTRY );
if( Options & OPT_BOUNDS ) {
hi_offset += BETypeLength( TY_POINTER );
}
hi_offset += (ss - 1) * (lo_size + BETypeLength( TY_ADV_HI_CV )) + lo_size;
hi = CGAssign( StructRef( adv, hi_offset ), hi, TY_ADV_HI_CV );
adv = GetAdv( arr );
}
if( Options & OPT_BOUNDS ) {
call = InitCall( RT_ADV_FILL_HI );
CGAddParm( call, hi, TY_INT_4 );
CGAddParm( call, CGInteger( ss, TY_UNSIGNED ), TY_UNSIGNED );
CGAddParm( call, adv, TY_LOCAL_POINTER );
CGDone( CGUnary( O_POINTS, CGCall( call ), TY_INT_4 ) );
} else {
hi_offset = (ss - 1) * ( lo_size + hi_size ) + lo_size;
num_elts = CGBinary( O_PLUS, hi,
CGBinary( O_MINUS, CGInteger( 1, TY_INTEGER ),
LoBound( arr, ss - 1 ),
TY_ADV_HI ),
TY_ADV_HI );
CGDone( CGAssign( StructRef( adv, hi_offset ), num_elts, TY_ADV_HI ) );
}
}
void FCAllocated( void ) {
//=====================
// Generate code for ALLOCATED intrinsic function.
uint type;
cg_name fl;
type = GetU16();
fl = XPop();
if( type & ALLOC_STRING ) {
fl = CGUnary( O_POINTS, fl, T_POINTER );
}
XPush( CGCompare( O_NE, fl, CGInteger( 0, T_POINTER ), T_POINTER ) );
}
static cg_name getFlags( sym_id sym ) {
//======================================
int tlen;
cg_name fl;
cg_type typ;
if( sym->ns.flags & SY_SUBSCRIPTED ) {
typ = ArrayPtrType( sym );
tlen = BETypeLength( typ );
} else {
tlen = BETypeLength( T_CHAR );
typ = T_CHAR;
}
fl = StructRef( CGFEName( sym, typ ), tlen );
return( CGUnary( O_POINTS, fl, T_UINT_2 ) );
}
static cg_name LoBound( sym_id arr, int ss_offset ) {
//====================================================
// Get lo bound from ADV.
cg_name lo_bound;
act_dim_list *dim_ptr;
dim_ptr = arr->u.ns.si.va.u.dim_ext;
if( _LoConstBound( dim_ptr->dim_flags, ss_offset + 1 ) ) {
lo_bound = CGInteger( ((intstar4 *)(&dim_ptr->subs_1_lo))[2*ss_offset],
TY_INT_4 );
} else {
lo_bound = CGUnary( O_POINTS,
StructRef( GetAdv( arr ),
ss_offset*BETypeLength( TY_ADV_ENTRY ) ),
TY_ADV_LO );
}
return( lo_bound );
}
void FCAdvFillHiLo1( void ) {
//========================
// Fill hi and lo=1 bound of a dimension.
sym_id arr;
cg_name lo;
cg_name hi;
cg_name adv;
unsigned ss;
uint lo_size;
uint hi_size;
int lo_offset;
int hi_offset;
call_handle call;
// Get general information
arr = GetPtr();
ss = GetU16();
adv = GetAdv( arr );
hi_size = BETypeLength( TY_ADV_HI );
lo_size = BETypeLength( TY_ADV_LO );
hi = GetTypedValue();
if( Options & OPT_BOUNDS ) {
call = InitCall( RT_ADV_FILL_HI_LO1 );
CGAddParm( call, hi, TY_INT_4 );
CGAddParm( call, CGInteger( ss, TY_UNSIGNED ), TY_UNSIGNED );
CGAddParm( call, adv, TY_LOCAL_POINTER );
CGDone( CGUnary( O_POINTS, CGCall( call ), TY_INT_4 ) );
} else {
hi_offset = (ss - 1) * ( lo_size + hi_size ) + lo_size;
CGDone( CGAssign( StructRef( adv, hi_offset ), hi, TY_ADV_HI ) );
// set lo bound of the adv
lo = CGInteger( 1, TY_INT_4 );
lo_offset = (ss - 1) * BETypeLength( TY_ADV_ENTRY );
adv = GetAdv( arr );
CGDone( CGAssign( StructRef( adv, lo_offset ), lo, TY_ADV_LO ) );
}
}
static void XMixed( int op, bool cmplx_scalar ) {
//===========================================
// Binary F-Code processor for cmplx-scalar addition & subtraction.
// cx - true if complex OP scalar, false if scalar OP complex.
cg_cmplx z;
cg_name x;
uint_16 typ_info;
cg_type z_typ;
cg_type x_typ;
typ_info = GetU16();
if( cmplx_scalar ) {
z_typ = GetType1( typ_info );
x_typ = GetType2( typ_info );
XPopCmplx( &z, z_typ );
x = XPopValue( x_typ );
} else {
x_typ = GetType1( typ_info );
z_typ = GetType2( typ_info );
x = XPopValue( x_typ );
XPopCmplx( &z, z_typ );
}
z_typ = CmplxBaseType( z_typ );
if( cmplx_scalar ) {
XPush( z.imagpart );
XPush( CGBinary( op, z.realpart, x, ResCGType( z_typ, x_typ ) ) );
} else {
if( op == O_MINUS ) {
XPush( CGUnary( O_UMINUS, z.imagpart, z_typ ) );
} else {
XPush( z.imagpart );
}
XPush( CGBinary( op, x, z.realpart, ResCGType( x_typ, z_typ ) ) );
}
}
void FCAssignedGOTOList( void ) {
//============================
// Perform assigned GOTO with list.
sel_handle s;
label_handle label;
sym_id sn;
sym_id var;
obj_ptr curr_obj;
var = GetPtr();
curr_obj = FCodeTell( 0 );
s = CGSelInit();
for(;;) {
sn = GetPtr();
if( sn == NULL ) break;
if( ( sn->u.st.flags & SN_IN_GOTO_LIST ) == 0 ) {
sn->u.st.flags |= SN_IN_GOTO_LIST;
label = GetStmtLabel( sn );
CGSelCase( s, label, sn->u.st.address );
}
}
label = BENewLabel();
CGSelOther( s, label );
CGSelect( s, CGUnary( O_POINTS, CGFEName( var, TY_INTEGER ), TY_INTEGER ) );
CGControl( O_LABEL, NULL, label );
BEFiniLabel( label );
FCodeSeek( curr_obj );
for(;;) {
sn = GetPtr();
if( sn == NULL ) break;
sn->u.st.flags &= ~SN_IN_GOTO_LIST;
RefStmtLabel( sn );
}
}
void FCPop( void ) {
//===============
// Process POP F-Code.
sym_id sym;
cg_name dst;
unsigned_16 typ_info;
cg_type dst_typ;
cg_type src_typ;
sym_id fd;
sym = GetPtr();
typ_info = GetU16();
dst_typ = GetType1( typ_info );
src_typ = GetType2( typ_info );
if( ( dst_typ == TY_COMPLEX ) || ( dst_typ == TY_DCOMPLEX )
|| ( dst_typ == TY_XCOMPLEX ) ) {
CmplxAssign( sym, dst_typ, src_typ );
} else {
if( (sym->ns.flags & SY_CLASS) == SY_SUBPROGRAM ) {
// it's a statement function
if( !(OZOpts & OZOPT_O_INLINE) ) {
dst = SymAddr( sym );
}
} else {
fd = NULL;
if( sym->ns.typ == FT_STRUCTURE ) {
if( GetU16() ) {
// target is a sub-field
dst = XPop();
if( dst_typ == TY_USER_DEFINED ) {
// sub-field is a structure or an array element
fd = GetPtr();
}
} else {
dst = SymAddr( sym );
}
} else if( sym->ns.flags & SY_SUBSCRIPTED ) {
// target is an array element
dst = XPop();
} else {
dst = SymAddr( sym );
}
if( dst_typ == TY_USER_DEFINED ) {
if( fd == NULL ) {
dst_typ = sym->ns.xt.record->cg_typ;
} else {
dst_typ = fd->fd.xt.record->cg_typ;
}
XPush( CGAssign( dst, CGUnary( O_POINTS, XPop(), dst_typ ),
dst_typ ) );
return;
}
}
if( (src_typ == TY_COMPLEX) || (src_typ == TY_DCOMPLEX)
|| (src_typ == TY_XCOMPLEX) ) {
Cmplx2Scalar();
src_typ = CmplxBaseType( src_typ );
}
if( ((sym->ns.flags & SY_CLASS) == SY_SUBPROGRAM) &&
(OZOpts & OZOPT_O_INLINE ) ) return;
XPush( CGAssign( dst, XPopValue( src_typ ), dst_typ ) );
}
}
cg_name CgFetchType( // PERFORM A FETCH
cg_name operand, // - operand to be fetched
cg_type type ) // - type of fetch
{
return CGUnary( O_POINTS, operand, type );
}
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 );
}
void CmplxAssign( sym_id sym, cg_type dst_typ, cg_type src_typ ) {
//===========================================================================
// Do complex assignment.
cg_type typ;
cg_name dest;
cg_name dest_1;
cg_name dest_2;
cg_cmplx z;
uint_16 flags;
temp_handle tr;
temp_handle ti;
flags = sym->u.ns.flags;
dest = NULL;
if( (flags & SY_CLASS) == SY_SUBPROGRAM ) {
// assigning to statement function
if( (OZOpts & OZOPT_O_INLINE) == 0 ) {
dest = SymAddr( sym );
}
} else {
// check for structure type before checking for array
// Consider: A(1).X = A(2).X
// where A is an array of structures containing complex field X
if( sym->u.ns.u1.s.typ == FT_STRUCTURE ) {
dest = XPop();
GetU16(); // ignore structure information
} else if( flags & SY_SUBSCRIPTED ) {
dest = XPop();
} else {
dest = SymAddr( sym );
}
}
typ = CmplxBaseType( dst_typ );
if( ( src_typ != TY_COMPLEX ) && ( src_typ != TY_DCOMPLEX ) &&
( src_typ != TY_XCOMPLEX ) ) {
z.realpart = XPopValue( src_typ );
z.imagpart = CGInteger( 0, typ );
} else {
XPopCmplx( &z, src_typ );
z.imagpart = CGEval( z.imagpart );
}
z.realpart = CGEval( z.realpart );
// Before assigning the real and imaginary parts, force evaluation of each.
// Consider: Z = Z * Z
// The above expression will be evaluated as follows.
// z.r = z.r*z.r - z.i*z.i
// z.i = z.r*z.i + z.r*z.i
// In the expression that evaluates the imaginary part, the value of "z.r"
// must be the original value and not the new value.
if( ((flags & SY_CLASS) == SY_SUBPROGRAM) && (OZOpts & OZOPT_O_INLINE) ) {
XPush( z.imagpart );
XPush( z.realpart );
return;
}
// Code to avoid the criss cross problem
// i.e. z = complx(imag(z), real(z))
// or similar problems due to overwriting of one part with the other
// before accessing it.
// This should not affect efficiency (for optimized code) very much
// because the temps will not be used when they are not required
tr = CGTemp( typ );
ti = CGTemp( typ );
CGDone( CGAssign( CGTempName( tr, typ ), z.realpart, typ ) );
CGDone( CGAssign( CGTempName( ti, typ ), z.imagpart, typ ) );
CloneCGName( dest, &dest_1, &dest_2 );
XPush( CGAssign( ImagPtr( dest_2, typ ),
CGUnary( O_POINTS, CGTempName( ti, typ ), typ ), typ ) );
XPush( CGAssign( dest_1, CGUnary( O_POINTS, CGTempName( tr, typ ), typ ),
typ ) );
}
