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