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 ) ); } }