static void ChkIOErr( cg_name io_stat ) {
//===========================================
// Check for i/o errors.
label_handle eq_label;
io_stat = CGUnary( O_POINTS, io_stat, TY_INTEGER );
if( ( EndEqLabel != 0 ) && ( ErrEqLabel != 0 ) ) {
eq_label = BENewLabel();
CG3WayControl( io_stat, GetLabel( EndEqLabel ), eq_label,
GetLabel( ErrEqLabel ) );
CGControl( O_LABEL, NULL, eq_label );
BEFiniLabel( eq_label );
} else if( EndEqLabel != 0 ) {
CGControl( O_IF_TRUE,
CGCompare( O_LT, io_stat, CGInteger( 0, TY_INTEGER ),
TY_INTEGER ),
GetLabel( EndEqLabel ) );
} else if( ErrEqLabel != 0 ) {
CGControl( O_IF_TRUE,
CGCompare( O_NE, io_stat, CGInteger( 0, TY_INTEGER ),
TY_INTEGER ),
GetLabel( ErrEqLabel ) );
} else if( IOStatSpecified ) {
IOSLabel = BENewLabel();
CGControl( O_IF_TRUE,
CGCompare( O_NE, io_stat, CGInteger( 0, TY_INTEGER ),
TY_INTEGER ),
IOSLabel );
} else {
CGDone( io_stat );
}
}
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 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 ) );
}
cg_name IntegerConstant( ftn_type *value, uint size ) {
//===================================================
if( size == sizeof( intstar1 ) ) {
return( CGInteger( value->intstar1, TY_INT_1 ) );
} else if( size == sizeof( intstar2 ) ) {
return( CGInteger( value->intstar2, TY_INT_2 ) );
} else {
return( CGInteger( value->intstar4, TY_INT_4 ) );
}
}
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 ) );
}
}
cg_name StructRef( cg_name structure, int offset ) {
//==================================================
// Reference a field in a structure.
return( CGBinary( O_PLUS, structure, CGInteger( offset, TY_INTEGER ), TY_LOCAL_POINTER ) );
}
void ArrayIO( RTCODE num_array, RTCODE chr_array ) {
//=====================================================
// Output an array.
sym_id arr;
sym_id field;
cg_name addr;
cg_name num_elts;
cg_name elt_size;
arr = GetPtr();
field = GetPtr();
if( field == NULL ) {
addr = SymAddr( arr );
num_elts = ArrayNumElts( arr );
if( arr->ns.typ == FT_CHAR ) {
ChrArrayIO( chr_array, addr, num_elts, ArrayEltSize( arr ) );
} else {
NumArrayIO( num_array, addr, num_elts,
ParmType( arr->ns.typ, arr->ns.xt.size ) );
}
} else { // must be a array field in a structure
addr = XPop();
num_elts = FieldArrayNumElts( field );
if( field->fd.typ == FT_CHAR ) {
elt_size = CGInteger( field->fd.xt.size, TY_INTEGER );
ChrArrayIO( chr_array, addr, num_elts, elt_size );
} else {
NumArrayIO( num_array, addr, num_elts,
ParmType( field->fd.typ, field->fd.xt.size ) );
}
}
}
cg_name FieldArrayNumElts( sym_id arr ) {
//=======================================
// Get number of elements in an array.
return( CGInteger( arr->u.fd.dim_ext->num_elts, TY_INT_4 ) );
}
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 );
}
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 ) );
}
static cg_name condSet( // SET/RESET FLAG
unsigned index, // - index of flag
bool set_flag, // - true ==> set the flag; false ==> clear
FN_CTL* fctl ) // - function information
{
cg_name op_flg; // - expression for flag setting
cg_name op_mask; // - mask operand
COND_INFO cond; // - conditional information
CondInfoSetup( index, &cond, fctl );
op_flg = CgSymbolPlusOffset( cond.sym, cond.offset );
if( set_flag ) {
op_mask = CGInteger( cond.mask, TY_UINT_1 );
op_flg = CGLVPreGets( O_OR, op_flg, op_mask, TY_UINT_1 );
} else {
op_mask = CGInteger( NOT_BITARR_MASK( cond.mask ), TY_UINT_1 );
op_flg = CGLVPreGets( O_AND, op_flg, op_mask, TY_UINT_1 );
}
return( op_flg );
}
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 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 ) );
}
}
static void VariableDims( sym_id arr ) {
//==========================================
// Subscript an array that has a variable array declarator.
act_dim_list *dim_ptr;
int dims_no;
int ss_offset;
cg_name offset;
cg_name c_offset;
dim_ptr = arr->u.ns.si.va.u.dim_ext;
dims_no = _DimCount( dim_ptr->dim_flags );
offset = CGInteger( 0, TY_INT_4 );
c_offset = CGInteger( 0, TY_INT_4 );
ss_offset = 0;
while( ss_offset < dims_no ) {
// offset += ( ss - lo ) * multiplier;
// or
// offset += ss*multiplier
// c_offset -= lo*multiplier
offset = CGBinary( O_PLUS,
offset,
CGBinary( O_TIMES,
GetTypedValue(),
Multiplier( arr, ss_offset ),
TY_INT_4 ),
TY_INT_4 );
c_offset = CGBinary( O_MINUS,
c_offset,
CGBinary( O_TIMES,
LoBound( arr, ss_offset ),
Multiplier( arr, ss_offset ),
TY_INT_4 ),
TY_INT_4 );
ss_offset++;
}
Index( arr, CGBinary( O_PLUS, c_offset, offset, TY_INT_4 ) );
}
cg_name ConstArrayOffset( act_dim_list *dims ) {
//==============================================
int dims_no;
cg_name hi_off;
intstar4 multiplier;
intstar4 hi;
intstar4 lo;
intstar4 *bounds;
intstar4 lo_off;
dims_no = _DimCount( dims->dim_flags );
bounds = &dims->subs_1_lo;
multiplier = 1;
hi_off = CGInteger( 0, TY_INT_4 );
lo_off = 0;
for(;;) {
lo = *bounds;
bounds++;
hi = *bounds;
bounds++;
// offset += ( ss - lo ) * multiplier;
// or
// hi_off += ss*multiplier
// lo_off -= lo*multiplier
hi_off = CGBinary( O_PLUS,
hi_off,
CGBinary( O_TIMES,
GetTypedValue(),
CGInteger( multiplier, TY_INT_4 ),
TY_INT_4 ),
TY_INT_4 );
lo_off -= lo * multiplier;
if( --dims_no == 0 ) break;
multiplier *= ( hi - lo + 1 );
}
return( CGBinary( O_PLUS, CGInteger( lo_off, TY_INT_4 ), hi_off, TY_INT_4 ) );
}
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 ) );
}
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 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 cg_name CharArrLength( sym_id sym ) {
//==========================================
// Get element size for character*(*) arrays.
if( sym->u.ns.flags & SY_VALUE_PARM ) {
return( CGInteger( 0, TY_INTEGER ) );
} else if( Options & OPT_DESCRIPTOR ) {
return( SCBLength( CGUnary( O_POINTS, CGFEName( sym, TY_POINTER ), TY_POINTER ) ) );
} else {
return( CGUnary( O_POINTS, CGFEName( FindArgShadow( sym ), TY_INTEGER ), TY_INTEGER ) );
}
}
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 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 FCIfArith( void ) {
//===================
// Set up control structure for arithmetic if.
cg_name if_expr;
sym_id lt;
sym_id eq;
sym_id gt;
cg_type typ;
typ = GetType( GetU16() );
if_expr = XPopValue( typ );
lt = GetPtr();
eq = GetPtr();
gt = GetPtr();
if( lt == gt ) {
CGControl( O_IF_TRUE,
CGCompare( O_EQ, if_expr, CGInteger( 0, typ ), typ ),
GetStmtLabel( eq ) );
CGControl( O_GOTO, NULL, GetStmtLabel( lt ) );
} else if( lt == eq ) {
CGControl( O_IF_TRUE,
CGCompare( O_GT, if_expr, CGInteger( 0, typ ), typ ),
GetStmtLabel( gt ) );
CGControl( O_GOTO, NULL, GetStmtLabel( eq ) );
} else if( eq == gt ) {
CGControl( O_IF_TRUE,
CGCompare( O_LT, if_expr, CGInteger( 0, typ ), typ ),
GetStmtLabel( lt ) );
CGControl( O_GOTO, NULL, GetStmtLabel( eq ) );
} else {
CG3WayControl( if_expr, GetStmtLabel( lt ), GetStmtLabel( eq ),
GetStmtLabel( gt ) );
}
RefStmtLabel( lt );
RefStmtLabel( eq );
RefStmtLabel( gt );
}
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 cg_name Multiplier( sym_id arr, int subs_no ) {
//=====================================================
// Compute mulitplier.
cg_name multiplier;
multiplier = CGInteger( 1, TY_INT_4 );
while( subs_no != 0 ) {
multiplier = CGBinary( O_TIMES, multiplier,
HiBound( arr, subs_no - 1 ), TY_INT_4 );
subs_no--;
}
return( multiplier );
}
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 );
}
cg_name ArrayNumElts( sym_id arr ) {
//==================================
// Get number of elements in an array.
cg_name num_elts;
act_dim_list *dim;
dim = arr->u.ns.si.va.u.dim_ext;
if( _AdvRequired( dim ) ) {
num_elts = Multiplier( arr, _DimCount( dim->dim_flags ) );
} else {
num_elts = CGInteger( dim->num_elts, TY_INT_4 );
}
return( num_elts );
}
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 FCAllocated( void ) {
//=====================
// Generate code for ALLOCATED intrinsic function.
uint type;
cg_name fl;
type = GetU16();
fl = XPop();
if( type & ALLOC_STRING ) {
fl = CGUnary( O_POINTS, fl, T_POINTER );
}
XPush( CGCompare( O_NE, fl, CGInteger( 0, T_POINTER ), T_POINTER ) );
}
cg_name ArrayEltSize( sym_id arr ) {
//==================================
// Get element size of an array.
cg_name elt_size;
uint size;
size = _SymSize( arr );
if( size == 0 ) { // character*(*) array
elt_size = CharItemLen( arr );
} else {
elt_size = CGInteger( size, TY_INTEGER );
}
return( elt_size );
}
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 ) );
}