static void XMulDivMix( int op, bool cmplx_scalar, uint_16 typ_info ) {
//=====================================================================
// Binary F-Code processor for mixed multiplication and division.
cg_cmplx z;
cg_name s;
cg_type s_typ;
cg_type z_typ;
cg_name s_1;
cg_name s_2;
if( cmplx_scalar ) {
z_typ = GetType1( typ_info );
s_typ = GetType2( typ_info );
XPopCmplx( &z, z_typ );
s = XPopValue( s_typ );
} else {
s_typ = GetType1( typ_info );
z_typ = GetType2( typ_info );
s = XPopValue( s_typ );
XPopCmplx( &z, z_typ );
}
z_typ = ResCGType( s_typ, CmplxBaseType( z_typ ) );
CloneCGName( s, &s_1, &s_2 );
XPush( CGBinary( op, z.imagpart, s_1, z_typ ) );
XPush( CGBinary( op, z.realpart, s_2, z_typ ) );
}
static void Equivalent( cg_op op_code ) {
//===========================================
cg_name op1;
cg_name op2;
unsigned_16 typ_info;
cg_type typ1;
cg_type typ2;
typ_info = GetU16();
typ1 = GetType1( typ_info );
typ2 = GetType2( typ_info );
op1 = XPopValue( typ1 );
op2 = XPopValue( typ2 );
typ1 = CGType( op1 );
if( typ1 != TY_BOOLEAN ) {
op1 = CGCompare( O_NE, op1, CGInteger( 0, typ1 ), typ1 );
}
typ2 = CGType( op2 );
if( typ2 != TY_BOOLEAN ) {
op2 = CGCompare( O_NE, op2, CGInteger( 0, typ2 ), typ2 );
}
XPush( CGCompare( op_code, op1, op2, TY_UINT_1 ) );
}
static void XCmplxMixOp( RTCODE rtn_id, bool cmplx_scalar ) {
//=======================================================
// F-Code processor for binary complex number operations involving
// runtime routines.
// x / (c,d) or (c,d) / x
uint_16 typ_info;
cg_type s_typ;
cg_type x_typ;
cg_name s;
cg_cmplx x;
typ_info = GetU16();
if( cmplx_scalar ) {
x_typ = GetType1( typ_info );
s_typ = GetType2( typ_info );
XPopCmplx( &x, x_typ );
s = XPopValue( s_typ );
} else {
s_typ = GetType1( typ_info );
x_typ = GetType2( typ_info );
s = XPopValue( s_typ );
XPopCmplx( &x, x_typ );
}
x_typ = ResCGType( s_typ, CmplxBaseType( x_typ ) );
if( cmplx_scalar ) {
// currently, the only time XCmplxMixOp() is called when the left
// operand is complex and the right operand is a scalar, is for
// exponentiation
s_typ = PromoteIntType( s_typ );
if( s_typ == TY_INT_4 ) {
DoCmplxScalarOp( RT_C8POWI, x.realpart, x.imagpart, s );
} else {
DoCmplxOp( rtn_id, x.realpart, x.imagpart, s, CGInteger( 0, x_typ ) );
}
} else {
DoCmplxOp( rtn_id, s, CGInteger( 0, x_typ ), x.realpart, x.imagpart );
}
}
static void CCCompare( int op ) {
//===========================
// Complex/Complex compare.
cg_cmplx x;
cg_cmplx y;
uint_16 typ_info;
typ_info = GetU16();
XPopCmplx( &x, GetType1( typ_info ) );
XPopCmplx( &y, GetType2( typ_info ) );
CCCmp( op, x.realpart, x.imagpart, y.realpart, y.imagpart );
}
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 ) ) );
}
}
static void CXCompare( int op ) {
//===================================
// Complex/Scalar compare.
cg_name x;
cg_cmplx z;
uint_16 typ_info;
cg_type typ2;
typ_info = GetU16();
typ2 = GetType2( typ_info );
XPopCmplx( &z, GetType1( typ_info ) );
x = XPopValue( typ2 );
CCCmp( op, z.realpart, z.imagpart, x, CGInteger( 0, typ2 ) );
}
static void XCmplxOp( RTCODE rtn_id ) {
//=================================
// F-Code processor for binary complex number operations involving
// runtime routines.
// ( a, b ) OP ( c, d ).
uint_16 typ_info;
cg_cmplx x;
cg_cmplx y;
typ_info = GetU16();
XPopCmplx( &x, GetType1( typ_info ) );
XPopCmplx( &y, GetType2( typ_info ) );
DoCmplxOp( rtn_id, x.realpart, x.imagpart, y.realpart, y.imagpart );
}
void XCCompare( int op ) {
//===========================
// Scalar/Complex compare.
cg_name x;
cg_cmplx z;
unsigned_16 typ_info;
cg_type typ1;
typ_info = GetU16();
typ1 = GetType1( typ_info );
x = XPopValue( typ1 );
XPopCmplx( &z, GetType2( typ_info ) );
CCCmp( op, x, CGInteger( 0, typ1 ), z.realpart, z.imagpart );
}
static void XLogic( int op_code ) {
//=====================================
// Logical operator F-Code processor.
cg_name op1;
cg_name op2;
unsigned_16 typ_info;
cg_type typ1;
cg_type typ2;
typ_info = GetU16();
typ1 = GetType1( typ_info );
typ2 = GetType2( typ_info );
op1 = XPopValue( typ1 );
op2 = XPopValue( typ2 );
XPush( CGFlow( op_code, op1, op2 ) );
}
static void XCmplx( int op ) {
//================================
// Binary operator F-Code processor for complex addition and subtraction.
uint_16 typ_info;
int typ1;
int typ2;
cg_cmplx x;
cg_cmplx y;
typ_info = GetU16();
typ1 = GetType1( typ_info );
typ2 = GetType2( typ_info );
XPopCmplx( &x, typ1 );
XPopCmplx( &y, typ2 );
typ1 = CmplxBaseType( typ1 );
typ2 = CmplxBaseType( typ2 );
XPush( CGBinary( op, x.imagpart, y.imagpart, ResCGType( typ1, typ2 ) ) );
XPush( CGBinary( op, x.realpart, y.realpart, ResCGType( typ1, typ2 ) ) );
}
static void InLineMulCC( uint_16 typ_info ) {
//===========================================
// Do complex multiplication in-line.
// (c,d) * (a,b).
cg_name d_1;
cg_name d_2;
cg_name c_1;
cg_name c_2;
cg_name b_1;
cg_name b_2;
cg_name a_1;
cg_name a_2;
cg_type typ1;
cg_type typ2;
cg_cmplx x;
cg_cmplx y;
typ1 = GetType1( typ_info );
typ2 = GetType2( typ_info );
XPopCmplx( &x, typ1 );
XPopCmplx( &y, typ2 );
typ1 = CmplxBaseType( typ1 );
typ2 = CmplxBaseType( typ2 );
CloneCGName( x.realpart, &a_1, &a_2 );
CloneCGName( x.imagpart, &b_1, &b_2 );
CloneCGName( y.realpart, &c_1, &c_2 );
CloneCGName( y.imagpart, &d_1, &d_2 );
typ1 = ResCGType( typ1, typ2 );
XPush( CGBinary( O_PLUS,
CGBinary( O_TIMES, a_1, d_1, typ1 ),
CGBinary( O_TIMES, b_1, c_1, typ1 ),
typ1 ) );
XPush( CGBinary( O_MINUS,
CGBinary( O_TIMES, a_2, c_2, typ1 ),
CGBinary( O_TIMES, b_2, d_2, typ1 ),
typ1 ) );
}
void FCSubString( void ) {
//=====================
// Do substring operation.
sym_id char_var;
sym_id dest;
cg_name src;
cg_name first_1;
cg_name first_2;
cg_name last;
unsigned_16 typ_info;
cg_name len;
cg_name ptr;
call_handle call;
char_var = GetPtr();
typ_info = GetU16();
src = XPop();
first_1 = XPopValue( GetType1( typ_info ) );
if( char_var == NULL ) { // i.e. chr(i:i)
len = CGInteger( GetInt(), TY_INTEGER );
if( Options & OPT_BOUNDS ) {
CloneCGName( first_1, &first_1, &last );
last = CGBinary( O_PLUS, last, len, TY_INTEGER );
last = CGBinary( O_MINUS, last, CGInteger( 1, TY_INTEGER ),
TY_INTEGER );
}
} else {
last = XPop();
if( last == NULL ) {
if( char_var->ns.xt.size == 0 ) {
last = CharItemLen( char_var );
} else {
last = CGInteger( char_var->ns.xt.size, TY_INTEGER );
}
} else {
XPush( last );
last = XPopValue( GetType2( typ_info ) );
}
if( !( Options & OPT_BOUNDS ) ) {
CloneCGName( first_1, &first_1, &first_2 );
len = CGBinary( O_MINUS, last, first_2, TY_INTEGER );
len = CGBinary( O_PLUS, len, CGInteger( 1, TY_INTEGER ), TY_INTEGER );
}
}
dest = GetPtr();
if( Options & OPT_BOUNDS ) {
call = InitCall( RT_SUBSTRING );
CGAddParm( call, CGFEName( dest, TY_CHAR ), TY_LOCAL_POINTER );
CGAddParm( call, last, TY_INT_4 );
CGAddParm( call, first_1, TY_INT_4 );
CGAddParm( call, src, TY_LOCAL_POINTER );
XPush( CGBinary( O_COMMA, CGCall( call ), CGFEName( dest, TY_CHAR ),
TY_LOCAL_POINTER ) );
} else {
ptr = CGBinary( O_PLUS, SCBPointer( src ),
CGBinary( O_MINUS, first_1, CGInteger( 1, TY_INTEGER ),
TY_INTEGER ),
TY_GLOBAL_POINTER );
CGTrash( CGAssign( SCBLenAddr( CGFEName( dest, TY_CHAR ) ),
len, TY_INTEGER ) );
// Assumption is that the pointer in the SCB is the first field in
// the SCB so that when we push the cg_name returned by CGAssign()
// it is a pointer to the SCB. We must leave the assignment of the
// pointer into the SCB in the tree so that the aliasing information
// is not lost.
XPush( CGLVAssign( SCBPtrAddr( CGFEName( dest, TY_CHAR ) ),
ptr, TY_GLOBAL_POINTER ) );
// Don't do it the following way:
// CGTrash( CGAssign( SCBPtrAddr( CGFEName( dest, TY_CHAR ) ),
// ptr, TY_GLOBAL_POINTER ) );
// XPush( CGFEName( dest, TY_CHAR ) );
}
}
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 ) );
}
}
