Exemplo n.º 1
0
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 ) );
}
Exemplo n.º 2
0
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 );
}
Exemplo n.º 3
0
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 ) ) );
}
Exemplo n.º 4
0
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 ) );
}
Exemplo n.º 5
0
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 ) );
}
Exemplo n.º 6
0
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 );
    }
}
Exemplo n.º 7
0
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 ) );
}
Exemplo n.º 8
0
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 ) );
}
Exemplo n.º 9
0
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 );
    }
}
Exemplo n.º 10
0
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 ) ) );
    }
}
Exemplo n.º 11
0
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 );
    }
}
Exemplo n.º 12
0
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 ) );
}
Exemplo n.º 13
0
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 ) );
    }
}
Exemplo n.º 14
0
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 );
}