static void DoCmplxScalarOp( RTCODE rtn_id, cg_name a, cg_name b, cg_name s ) { //========================================================================= // Do a complex operation. call_handle handle; cg_type typ; cg_type r_typ; typ = CGType( a ); if( typ == TY_DOUBLE ) { rtn_id += RT_C_DOUBLE; r_typ = TY_DCOMPLEX; } else if( typ == TY_LONGDOUBLE ) { rtn_id += RT_C_EXTENDED; r_typ = TY_XCOMPLEX; } else { r_typ = TY_COMPLEX; } handle = InitCall( rtn_id ); CGAddParm( handle, a, typ ); CGAddParm( handle, b, typ ); CGAddParm( handle, s, PromoteIntType( CGType( s ) ) ); SplitCmplx( CGCall( handle ), r_typ ); }
cg_name Concat( uint num_args, cg_name dest ) { //============================================= // Do concatenation operation. int count; call_handle call; cg_name dest_1; cg_name dest_2; if( num_args & CAT_TEMP ) { call = InitCall( RT_TCAT ); num_args &= ~CAT_TEMP; } else if( num_args == 1 ) { call = InitCall( RT_MOVE ); } else { call = InitCall( RT_CAT ); } count = num_args; while( count > 0 ) { CGAddParm( call, StkElement( count ), TY_LOCAL_POINTER ); --count; } PopStkElements( num_args ); CloneCGName( dest, &dest_1, &dest_2 ); CGAddParm( call, dest_1, TY_LOCAL_POINTER ); if( num_args != 1 ) { CGAddParm( call, CGInteger( num_args, TY_UNSIGNED ), TY_UNSIGNED ); } return( CGBinary( O_COMMA, CGCall( call ), dest_2, TY_LOCAL_POINTER ) ); }
void DoCmplxOp( RTCODE rtn_id, cg_name a, cg_name b, cg_name c, cg_name d ) { //=========================================================================== // Do a complex operation. call_handle handle; cg_type typ; cg_type r_typ; typ = ResCGType( CGType( a ), CGType( c ) ); if( typ == TY_DOUBLE ) { rtn_id += RT_C_DOUBLE; r_typ = TY_DCOMPLEX; } else if( typ == TY_LONGDOUBLE ) { rtn_id += RT_C_EXTENDED; r_typ = TY_XCOMPLEX; } else { r_typ = TY_COMPLEX; } handle = InitCall( rtn_id ); CGAddParm( handle, a, typ ); CGAddParm( handle, b, typ ); CGAddParm( handle, c, typ ); CGAddParm( handle, d, typ ); SplitCmplx( CGCall( handle ), r_typ ); }
static void DbSubscript( sym_id arr ) { //========================================= // Generate call to debugging subscript routine. act_dim_list *dim_ptr; int dims_no; int i; call_handle call; cg_name offset; cg_name subscripts[MAX_DIM]; dim_ptr = arr->u.ns.si.va.u.dim_ext; dims_no = _DimCount( dim_ptr->dim_flags ); call = InitCall( RT_SUBSCRIPT ); for( i = 0; i < dims_no; ++i ) { subscripts[ i ] = GetTypedValue(); } for( i = 1; i <= dims_no; ++i ) { CGAddParm( call, subscripts[ dims_no - i ], TY_INT_4 ); } CGAddParm( call, GetAdv( arr ), TY_LOCAL_POINTER ); CGAddParm( call, CGInteger( _DimCount( dim_ptr->dim_flags ), TY_INTEGER ), TY_INTEGER ); offset = CGUnary( O_POINTS, CGCall( call ), TY_INT_4 ); Index( arr, offset ); }
void FCDeAllocate( void ) { //============================== call_handle handle; sym_id arr; uint num; num = 0; handle = InitCall( RT_DEALLOCATE ); for(;;) { arr = GetPtr(); if( arr == NULL ) break; CGAddParm( handle, CGFEName( arr, T_POINTER ), T_POINTER ); CGAddParm( handle, getFlags( arr ), FLAG_PARM_TYPE ); ++num; } CGAddParm( handle, CGInteger( num, T_INTEGER ), T_INTEGER ); if( GetU16() & ALLOC_STAT ) { FCodeSequence(); CGAddParm( handle, XPop(), T_POINTER ); } else { CGAddParm( handle, CGInteger( 0, T_POINTER ), T_POINTER ); } CGDone( CGCall( handle ) ); }
static void IOString( RTCODE rtn ) { //====================================== call_handle handle; handle = InitCall( rtn ); CGAddParm( handle, XPop(), TY_INTEGER ); CGAddParm( handle, XPop(), TY_POINTER ); CGDone( CGCall( handle ) ); }
static void NumArrayIO( RTCODE rtn, cg_name arr, cg_name num_elts, uint typ ) { //==================================================================== call_handle call; call = InitCall( rtn ); CGAddParm( call, CGInteger( typ, TY_INTEGER ), TY_INTEGER ); CGAddParm( call, num_elts, TY_INT_4 ); CGAddParm( call, arr, TY_POINTER ); CGDone( CGCall( call ) ); }
static void ChrArrayIO( RTCODE rtn, cg_name arr, cg_name num_elts, cg_name elt_size ) { //==================================================================== call_handle call; call = InitCall( rtn ); CGAddParm( call, elt_size, TY_INTEGER ); CGAddParm( call, num_elts, TY_INT_4 ); CGAddParm( call, arr, TY_POINTER ); CGDone( CGCall( call ) ); }
void FCSetIntl( void ) { //=================== // Call runtime routine to set internal file to character item (not array). call_handle handle; handle = InitCall( RT_SET_INTL ); CGAddParm( handle, CGInteger( 1, TY_INT_4 ), TY_INT_4 ); CGAddParm( handle, XPop(), TY_POINTER ); CGDone( CGCall( handle ) ); }
void FCFmtScan( void ) { //=================== // Call runtime routine to scan a format specification from a character // expression. call_handle handle; handle = InitCall( RT_FMT_SCAN ); CGAddParm( handle, CGInteger( GetU16(), TY_UNSIGNED ), TY_UNSIGNED ); CGAddParm( handle, XPop(), TY_POINTER ); CGDone( CGCall( handle ) ); }
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 ) ); }
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 addArgument( // ADD AN ARGUMENT call_handle handle, // - handle for call cg_name expr, // - expression for argument cg_type type ) // - argument type { CGAddParm( handle, expr, type ); }
void FCFmtArrScan( void ) { //====================== // Call runtime routine to scan a format specification from a character // array. call_handle handle; sym_id sym; sym = GetPtr(); handle = InitCall( RT_FMT_ARR_SCAN ); CGAddParm( handle, CGInteger( GetU16(), TY_UNSIGNED ), TY_UNSIGNED ); CGAddParm( handle, ArrayEltSize( sym ), TY_UNSIGNED ); CGAddParm( handle, ArrayNumElts( sym ), TY_INT_4 ); CGAddParm( handle, SymAddr( sym ), TY_POINTER ); CGDone( CGCall( handle ) ); }
static void Output( RTCODE rtn, cg_type arg_type ) { //====================================================== // Call runtime routine to output elemental types value. call_handle handle; handle = InitCall( rtn ); CGAddParm( handle, XPopValue( arg_type ), PromoteToBaseType( arg_type ) ); CGDone( CGCall( handle ) ); }
static void IOCall( RTCODE rtn ) { //==================================== // Call i/o run-time routine with one argument. call_handle handle; handle = InitCall( rtn ); CGAddParm( handle, XPop(), TY_POINTER ); CGDone( CGCall( handle ) ); }
void FCPassLabel( void ) { //===================== // Pass label to run-time routine. call_handle handle; handle = InitCall( GetU16() ); CGAddParm( handle, CGBackName( (back_handle)GetLabel( GetU16() ), TY_POINTER ), TY_POINTER ); CGDone( CGCall( handle ) ); }
static void IOCallValue( RTCODE rtn ) { //========================================= // Call i/o run-time routine with one argument. call_handle handle; handle = InitCall( rtn ); CGAddParm( handle, GetTypedValue(), TY_INT_4 ); CGDone( CGCall( handle ) ); }
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 ) ); }
static void Input( RTCODE rtn ) { //=================================== // Common input routine. call_handle handle; handle = InitCall( rtn ); CGAddParm( handle, XPop(), TY_POINTER ); CGDone( CGCall( handle ) ); }
void FCSetFmt( void ) { //================== // Set format string from FORMAT statement. call_handle handle; handle = InitCall( RT_SET_FMT ); CGAddParm( handle, CGBackName( (back_handle)GetStmtLabel( GetPtr() ), TY_POINTER ), TY_POINTER ); CGDone( CGCall( handle ) ); }
void FCOutCHAR( void ) { //=================== // Call runtime routine to output CHARACTER*n value. call_handle handle; handle = InitCall( RT_OUT_CHAR ); CGAddParm( handle, XPop(), TY_POINTER ); CGDone( CGCall( handle ) ); }
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 ) ); } }
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 FCSetNml( void ) { //================== // Set NAMELIST format. call_handle handle; sym_id nl; grp_entry *ge; NmlSpecified = TRUE; handle = InitCall( RT_SET_NML ); nl = GetPtr(); ReverseList( &nl->nl.group_list ); ge = nl->nl.group_list; while( ge != NULL ) { CGAddParm( handle, SymAddr( ge->sym ), TY_POINTER ); ge = ge->link; } ReverseList( &nl->nl.group_list ); CGAddParm( handle, CGBackName( nl->nl.address, TY_POINTER ), TY_POINTER ); CGDone( CGCall( handle ) ); }
void FCFmtAssign( void ) { //===================== // Set FORMAT string for: // ASSIGN 10 TO I // PRINT I, ... // 10 FORMAT( ... ) call_handle handle; handle = InitCall( RT_SET_FMT ); CGAddParm( handle, CGUnary( O_POINTS, SymAddr( GetPtr() ), TY_POINTER ), TY_POINTER ); CGDone( CGCall( handle ) ); }
void FCSetLine( void ) { //=================== // Generate run-time call to ISN routine. call_handle handle; unsigned_16 line_num; line_num = GetU16(); if( ( SubProgId->ns.flags & SY_SUBPROG_TYPE ) == SY_BLOCK_DATA ) return; handle = InitCall( RT_SET_LINE ); CGAddParm( handle, CGInteger( line_num, TY_INTEGER ), TY_INTEGER ); CGDone( CGCall( handle ) ); }
static void Break( RTCODE routine ) { //======================================= // Process PAUSE/STOP statement. call_handle handle; sym_id lit; cg_name arg; handle = InitCall( routine ); lit = GetPtr(); if( lit == NULL ) { arg = CGInteger( 0, TY_LOCAL_POINTER ); } else { arg = CGBackName( ConstBack( lit ), TY_LOCAL_POINTER ); } CGAddParm( handle, arg, TY_LOCAL_POINTER ); CGDone( CGCall( handle ) ); }
void FCAllocate( void ) { //============================ call_handle handle; sym_id arr; act_dim_list *dim; uint num; unsigned_16 alloc_flags; cg_name expr_stat; cg_name expr_loc; cg_name fl; label_handle label; num = 0; SymPush( NULL ); for(;;) { arr = GetPtr(); if( arr == NULL ) break; // check if array is already allocated before filling in ADV label = BENewLabel(); fl = getFlags( arr ); fl = CGBinary( O_AND, fl, CGInteger( ALLOC_MEM, T_UINT_2 ), T_UINT_2 ); CGControl( O_IF_TRUE, CGCompare( O_NE, fl, CGInteger( 0, T_UINT_2 ), T_UINT_2 ), label ); FCodeSequence(); // fill in the ADV, SCB or RCB CGControl( O_LABEL, NULL, label ); BEFiniLabel( label ); SymPush( arr ); ++num; } alloc_flags = GetU16(); if( alloc_flags & ALLOC_NONE ) { expr_loc = CGInteger( 0, T_POINTER ); } else { FCodeSequence(); if( alloc_flags & ALLOC_LOC ) { expr_loc = XPopValue( T_INT_4 ); if( alloc_flags & ALLOC_STAT ) { FCodeSequence(); expr_stat = XPop(); } } else { expr_stat = XPop(); } } handle = InitCall( RT_ALLOCATE ); for(;;) { arr = SymPop(); if( arr == NULL ) break; if( arr->ns.flags & SY_SUBSCRIPTED ) { dim = arr->ns.si.va.dim_ext; CGAddParm( handle, CGInteger( _SymSize( arr ), T_INT_4 ), T_INT_4 ); CGAddParm( handle, CGInteger( _DimCount( dim->dim_flags ), T_INTEGER ), T_INTEGER ); CGAddParm( handle, GetAdv( arr ), T_LOCAL_POINTER ); } CGAddParm( handle, CGFEName( arr, T_POINTER ), T_POINTER ); CGAddParm( handle, getFlags( arr ), FLAG_PARM_TYPE ); } if( alloc_flags & ALLOC_NONE ) { CGAddParm( handle, expr_loc, T_POINTER ); } else { if( alloc_flags & ALLOC_LOC ) { CGAddParm( handle, expr_loc, T_INT_4 ); } if( alloc_flags & ALLOC_STAT ) { CGAddParm( handle, expr_stat, T_POINTER ); } } CGAddParm( handle, CGInteger( num, T_INTEGER ), T_INTEGER ); CGAddParm( handle, CGInteger( alloc_flags, T_UINT_2 ), FLAG_PARM_TYPE ); CGDone( CGCall( handle ) ); }
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 ) ); } }