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 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 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 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 ); }
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 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 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 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 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 OutCplx( RTCODE rtn, cg_type typ ) { //=============================================== // Call runtime routine to input COMPLEX value. call_handle handle; cg_cmplx z; handle = InitCall( rtn ); XPopCmplx( &z, typ ); typ = CmplxBaseType( typ ); CGAddParm( handle, z.imagpart, typ ); CGAddParm( handle, z.realpart, typ ); CGDone( CGCall( handle ) ); }
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 ) ); }
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 ); }
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 ); } }
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 ) ); }