void FCCmplxFlip( void ) {
//=====================
// Flip 2 complex operands.
cg_name rp_1;
cg_name ip_1 = NULL;
cg_name rp_2;
cg_name ip_2 = NULL;
rp_1 = XPop();
if( !TypePointer( CGType( rp_1 ) ) ) {
ip_1 = XPop();
}
rp_2 = XPop();
if( !TypePointer( CGType( rp_2 ) ) ) {
ip_2 = XPop();
}
if( !TypePointer( CGType( rp_1 ) ) ) {
XPush( ip_1 );
}
XPush( rp_1 );
if( !TypePointer( CGType( rp_2 ) ) ) {
XPush( ip_2 );
}
XPush( rp_2 );
}
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 ) );
}
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 );
}
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 ) );
}
void FCNot( void ) {
//===============
// Logical .NOT. F-Code processor.
XPush( CGFlow( O_FLOW_NOT, GetTypedValue(), NULL ) );
}
void PushComplex( sym_id sym ) {
//=================================
// Push a complex number.
XPush( SymAddr( sym ) );
}
void FCCat( void ) {
//===============
// Do concatenation operation.
XPush( Concat( GetU16(), XPop() ) );
}
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 Index( sym_id arr, cg_name offset ) {
//===================================================
// Perform indexing operation.
offset = CGBinary( O_TIMES, offset, ArrayEltSize( arr ), TY_INT_4 );
XPush( SymIndex( arr, offset ) );
}
void FCPushSCBLen( void ) {
//======================
// NULL "last" means we need the length from the SCB in the character*(*) case.
// See FCSubString().
XPush( NULL );
}
static void StructIOItem( sym_id fd ) {
//=========================================
// Perform i/o of structure field.
RTCODE rtn;
if( fd->fd.dim_ext == NULL ) {
XPush( TmpVal( TmpStructPtr, TY_POINTER ) );
if( fd->fd.typ == FT_CHAR ) {
XPush( CGInteger( fd->fd.xt.size, TY_INTEGER ) );
}
IORtnTable[ ParmType( fd->fd.typ, fd->fd.xt.size ) ]();
CGTrash( CGAssign( TmpPtr( TmpStructPtr, TY_POINTER ),
CGBinary( O_PLUS,
TmpVal( TmpStructPtr, TY_POINTER ),
CGInteger( fd->fd.xt.size, TY_UINT_4 ),
TY_POINTER ),
TY_POINTER ) );
} else {
if( IORtnTable == &OutRtn ) {
rtn = RT_PRT_ARRAY;
} else {
rtn = RT_INP_ARRAY;
}
if( fd->fd.typ == FT_CHAR ) {
ChrArrayIO( rtn + 1, TmpVal( TmpStructPtr, TY_POINTER ),
CGInteger( fd->fd.dim_ext->num_elts, TY_INT_4 ),
CGInteger( fd->fd.xt.size, TY_INTEGER ) );
} else {
NumArrayIO( rtn, TmpVal( TmpStructPtr, TY_POINTER ),
CGInteger( fd->fd.dim_ext->num_elts, TY_INT_4 ),
ParmType( fd->fd.typ, fd->fd.xt.size ) );
}
CGTrash( CGAssign( TmpPtr( TmpStructPtr, TY_POINTER ),
CGBinary( O_PLUS,
TmpVal( TmpStructPtr, TY_POINTER ),
CGInteger( fd->fd.xt.size *
fd->fd.dim_ext->num_elts,
TY_UINT_4 ),
TY_POINTER ),
TY_POINTER ) );
}
}
void FCPushConst( void ) {
//=====================
// Process PUSH_CONST F-Code.
sym_id sym;
char fmt_buff[CONVERSION_BUFFER+1];
sym = GetPtr();
switch( sym->cn.typ ) {
case FT_INTEGER_1 :
case FT_INTEGER_2 :
case FT_INTEGER :
XPush( IntegerConstant( &sym->cn.value, sym->cn.size ) );
break;
case FT_LOGICAL_1 :
case FT_LOGICAL :
XPush( CGInteger( sym->cn.value.logstar4, TY_UINT_1 ) );
break;
case FT_REAL :
CnvS2S( &sym->cn.value.single, fmt_buff );
XPush( CGFloat( fmt_buff, TY_SINGLE ) );
break;
case FT_DOUBLE :
CnvD2S( &sym->cn.value.dble, fmt_buff );
XPush( CGFloat( fmt_buff, TY_DOUBLE ) );
break;
case FT_TRUE_EXTENDED :
CnvX2S( &sym->cn.value.extended, fmt_buff );
XPush( CGFloat( fmt_buff, TY_LONGDOUBLE ) );
break;
case FT_COMPLEX :
PushCmplxConst( sym );
break;
case FT_DCOMPLEX :
PushCmplxConst( sym );
break;
case FT_TRUE_XCOMPLEX :
PushCmplxConst( sym );
break;
}
}
void FCXCFlip( void ) {
//==================
// Flip scalar and complex operands.
cg_name rp;
cg_name ip = NULL;
cg_name scalar;
scalar = XPop();
rp = XPop();
if( !TypePointer( CGType( rp ) ) ) {
ip = XPop();
}
XPush( scalar );
if( !TypePointer( CGType( rp ) ) ) {
XPush( ip );
}
XPush( rp );
}
void FCCXFlip( void ) {
//==================
// Flip complex and scalar operands.
cg_name rp;
cg_name ip = NULL;
cg_name scalar;
rp = XPop();
if( !TypePointer( CGType( rp ) ) ) {
ip = XPop();
}
scalar = XPop();
if( !TypePointer( CGType( rp ) ) ) {
XPush( ip );
}
XPush( rp );
XPush( scalar );
}
void FCMakeSCB( void ) {
//===================
cg_name len;
cg_name ptr;
ptr = XPop();
len = XPop();
XPush( ptr );
MakeSCB( GetPtr(), len );
}
void FCChar1Move( void ) {
//=====================
// Perform single character assignment.
cg_type typ;
cg_name dest;
typ = GetType( GetU16() );
dest = XPop();
XPush( CGLVAssign( SCBPointer( dest ), GetChOp( typ ), typ ) );
}
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 ) ) );
}
void FCPushLit( void ) {
//===================
// Process PUSH_LIT F-Code.
sym_id sym;
sym = GetPtr();
if( sym->lt.flags & (LT_SCB_REQUIRED | LT_SCB_TMP_REFERENCE) ) {
XPush( CGBackName( ConstBack( sym ), TY_CHAR ) );
}
}
void Cmplx2Scalar( void ) {
//==============================
// Convert complex to scalar.
cg_name opn;
opn = XPop();
if( !TypePointer( CGType( opn ) ) ) {
CGTrash( XPop() );
}
XPush( opn );
}
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 MakeSCB( sym_id scb, cg_name len ) {
//==========================================
// Make an SCB.
CGTrash( CGAssign( SCBLenAddr( CGFEName( scb, 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
XPush( CGLVAssign( SCBPtrAddr( CGFEName( scb, TY_CHAR ) ), XPop(), TY_POINTER ) );
// Don't do it the following way:
// CGTrash( CGAssign( SCBPtrAddr( CGFEName( scb, TY_CHAR ) ), XPop(), TY_POINTER ) );
// XPush( CGFEName( scb, TY_CHAR ) );
}
void FCPush( void ) {
//================
// Process PUSH F-Code.
sym_id sym;
sym = GetPtr();
if( TypeCmplx( sym->ns.typ ) ) {
PushComplex( sym );
} else {
XPush( SymAddr( sym ) );
}
}
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 );
}
}
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 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 void CCCmp( cg_op op, cg_name a, cg_name b, cg_name c, cg_name d ) {
//=============================================================================
// Complex/Complex compare.
cg_type res_type;
cg_op flow_op;
res_type = ResCGType( CGType( a ), CGType( c ) );
if( op == O_EQ ) {
flow_op = O_FLOW_AND;
} else {
flow_op = O_FLOW_OR;
}
XPush( CGFlow( flow_op, CGCompare( op, a, c, res_type ),
CGCompare( op, b, d, res_type ) ) );
}
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 ) );
}
void FCCharNMove( void ) {
//=====================
// Perform N character assignment of non optimal lengths.
int src_len;
int dst_len;
cg_name dst;
cg_name dst2;
call_handle call;
bool equal = FALSE;
src_len = GetInt();
dst_len = GetInt();
if( src_len < dst_len ) {
call = InitInlineCall( INLINE_STRBLAST_NE );
} else {
src_len = dst_len;
equal = TRUE;
call = InitInlineCall( INLINE_STRBLAST_EQ );
}
dst = XPop();
CloneCGName( dst, &dst, &dst2 );
if( OZOpts & OZOPT_O_SPACE || !equal ) {
CGAddParm( call, CGInteger( src_len, TY_INTEGER ), TY_INTEGER );
} else {
// Special but common case, so we optimize it.
CGAddParm( call, CGInteger( src_len & TAIL_MASK, TY_INTEGER ),
TY_INTEGER );
CGAddParm( call, CGInteger( src_len >> TAIL_SHIFT, TY_INTEGER ),
TY_INTEGER );
}
CGAddParm( call, SCBPointer( XPop() ), TY_LOCAL_POINTER );
if( !equal ) {
CGAddParm( call, CGInteger( dst_len - src_len, TY_INTEGER ), TY_INTEGER );
}
CGAddParm( call, SCBPointer( dst ), TY_LOCAL_POINTER );
XPush( CGBinary( O_COMMA, CGCall( call ), dst2, TY_LOCAL_POINTER ) );
}
void PushCmplxConst( sym_id sym ) {
//============================================
// Push a complex constant.
char fmt_buff[80];
if( sym->u.cn.typ == FT_COMPLEX ) {
CnvS2S( &sym->u.cn.value.scomplex.imagpart, fmt_buff );
XPush( CGFloat( fmt_buff, TY_SINGLE ) );
CnvS2S( &sym->u.cn.value.scomplex.realpart, fmt_buff );
XPush( CGFloat( fmt_buff, TY_SINGLE ) );
} else if( sym->u.cn.typ == FT_DCOMPLEX ) {
CnvD2S( &sym->u.cn.value.dcomplex.imagpart, fmt_buff );
XPush( CGFloat( fmt_buff, TY_DOUBLE ) );
CnvD2S( &sym->u.cn.value.dcomplex.realpart, fmt_buff );
XPush( CGFloat( fmt_buff, TY_DOUBLE ) );
} else {
CnvX2S( &sym->u.cn.value.xcomplex.imagpart, fmt_buff );
XPush( CGFloat( fmt_buff, TY_LONGDOUBLE ) );
CnvX2S( &sym->u.cn.value.xcomplex.realpart, fmt_buff );
XPush( CGFloat( fmt_buff, TY_LONGDOUBLE ) );
}
}
