void FCAdvFillHi( void ) { //===================== // Fill hi bound of a dimension (actually computes # of elements in dimension). sym_id arr; act_dim_list *dim_ptr; uint lo_size; uint hi_size; int hi_offset; int ss; cg_name num_elts; cg_name hi; cg_name adv; call_handle call; arr = GetPtr(); dim_ptr = arr->u.ns.si.va.u.dim_ext; adv = GetAdv( arr ); hi_size = BETypeLength( TY_ADV_HI ); lo_size = BETypeLength( TY_ADV_LO ); ss = GetU16(); hi = GetTypedValue(); if( CGOpts & CGOPT_DI_CV ) { hi_offset = _DimCount( dim_ptr->dim_flags ) * BETypeLength( TY_ADV_ENTRY ); if( Options & OPT_BOUNDS ) { hi_offset += BETypeLength( TY_POINTER ); } hi_offset += (ss - 1) * (lo_size + BETypeLength( TY_ADV_HI_CV )) + lo_size; hi = CGAssign( StructRef( adv, hi_offset ), hi, TY_ADV_HI_CV ); adv = GetAdv( arr ); } if( Options & OPT_BOUNDS ) { call = InitCall( RT_ADV_FILL_HI ); CGAddParm( call, hi, TY_INT_4 ); CGAddParm( call, CGInteger( ss, TY_UNSIGNED ), TY_UNSIGNED ); CGAddParm( call, adv, TY_LOCAL_POINTER ); CGDone( CGUnary( O_POINTS, CGCall( call ), TY_INT_4 ) ); } else { hi_offset = (ss - 1) * ( lo_size + hi_size ) + lo_size; num_elts = CGBinary( O_PLUS, hi, CGBinary( O_MINUS, CGInteger( 1, TY_INTEGER ), LoBound( arr, ss - 1 ), TY_ADV_HI ), TY_ADV_HI ); CGDone( CGAssign( StructRef( adv, hi_offset ), num_elts, TY_ADV_HI ) ); } }
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 FCIntlArrSet( void ) { //====================== // Call runtime routine to set internal file to character array. call_handle handle; sym_id sym; sym_id scb; sym = GetPtr(); scb = GetPtr(); CGTrash( CGAssign( SCBLenAddr( CGFEName( scb, TY_POINTER ) ), ArrayEltSize( sym ), TY_INTEGER ) ); CGTrash( CGAssign( SCBPtrAddr( CGFEName( scb, TY_POINTER ) ), SymAddr( sym ), TY_POINTER ) ); handle = InitCall( RT_SET_INTL ); CGAddParm( handle, ArrayNumElts( sym ), TY_INT_4 ); CGAddParm( handle, CGFEName( scb, TY_POINTER ), TY_POINTER ); CGDone( CGCall( handle ) ); }
void FCAssign( void ) { //================== // Process ASSIGN statement. sym_id stmt; stmt = GetPtr(); if( stmt->u.st.flags & SN_FORMAT ) { CGDone( CGAssign( SymAddr( GetPtr() ), CGBackName( GetFmtLabel( stmt->u.st.address ), TY_LOCAL_POINTER ), TY_LOCAL_POINTER ) ); } else { CGDone( CGAssign( SymAddr( GetPtr() ), CGInteger( stmt->u.st.address, TY_INTEGER ), TY_INTEGER ) ); RefStmtLabel( stmt ); } }
void FCAdvFillHiLo1( void ) { //======================== // Fill hi and lo=1 bound of a dimension. sym_id arr; cg_name lo; cg_name hi; cg_name adv; unsigned ss; uint lo_size; uint hi_size; int lo_offset; int hi_offset; call_handle call; // Get general information arr = GetPtr(); ss = GetU16(); adv = GetAdv( arr ); hi_size = BETypeLength( TY_ADV_HI ); lo_size = BETypeLength( TY_ADV_LO ); hi = GetTypedValue(); if( Options & OPT_BOUNDS ) { call = InitCall( RT_ADV_FILL_HI_LO1 ); CGAddParm( call, hi, TY_INT_4 ); CGAddParm( call, CGInteger( ss, TY_UNSIGNED ), TY_UNSIGNED ); CGAddParm( call, adv, TY_LOCAL_POINTER ); CGDone( CGUnary( O_POINTS, CGCall( call ), TY_INT_4 ) ); } else { hi_offset = (ss - 1) * ( lo_size + hi_size ) + lo_size; CGDone( CGAssign( StructRef( adv, hi_offset ), hi, TY_ADV_HI ) ); // set lo bound of the adv lo = CGInteger( 1, TY_INT_4 ); lo_offset = (ss - 1) * BETypeLength( TY_ADV_ENTRY ); adv = GetAdv( arr ); CGDone( CGAssign( StructRef( adv, lo_offset ), lo, TY_ADV_LO ) ); } }
cg_name CmplxAddr( cg_name real, cg_name imag ) { //======================================================= // Pass a complex value to a subprogram. tmp_handle tmp; cg_type typ; cg_type c_type; typ = CGType( real ); if( typ == TY_SINGLE ) { c_type = TY_COMPLEX; } else if( typ == TY_DOUBLE ) { c_type = TY_DCOMPLEX; } else { c_type = TY_XCOMPLEX; } tmp = AllocTmp( c_type ); CGTrash( CGAssign( TmpPtr( tmp, c_type ), real, typ ) ); CGTrash( CGAssign( ImagPtr( TmpPtr( tmp, c_type ), typ ), imag, typ ) ); return( TmpPtr( tmp, c_type ) ); }
void FCSetSCBLen( void ) { //===================== // Fill scb length sym_id scb; cg_name len; // Get general information scb = GetPtr(); len = GetTypedValue(); CGTrash( CGAssign( SCBLenAddr( CGFEName( scb, TY_CHAR ) ), len, TY_INTEGER ) ); }
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 FCAdvFillLo( void ) { //===================== // Fill lo bound of a dimension. sym_id arr; int lo_offset; cg_name adv; cg_name lo; unsigned ss; arr = GetPtr(); adv = GetAdv( arr ); ss = GetU16(); lo = GetTypedValue(); lo_offset = (ss - 1) * BETypeLength( TY_ADV_ENTRY ); CGDone( CGAssign( StructRef( adv, lo_offset ), lo, TY_ADV_LO ) ); }
static void DoStructArrayIO( tmp_handle num_elts, struct field *fieldz ) { //============================================================================ // Perform structure array i/o. label_handle label; label = BENewLabel(); CGControl( O_LABEL, NULL, label ); StructIO( fieldz ); CGControl( O_IF_TRUE, CGCompare( O_NE, CGAssign( TmpPtr( num_elts, TY_INT_4 ), CGBinary( O_MINUS, TmpVal( num_elts, TY_INT_4 ), CGInteger( 1, TY_INTEGER ), TY_INT_4 ), TY_INT_4 ), CGInteger( 0, TY_INTEGER ), TY_INT_4 ), label ); BEFiniLabel( label ); }
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 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 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 ) ); }
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 ) ); } }