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 ) );
}
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 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 FCCmplxDone( void ) {
//===========================
// Process end of a complex expression.
CGDone( CGBinary( O_COMMA, XPop(), XPop(), TY_DEFAULT ) );
}
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 ) );
}
static void Index( sym_id arr, cg_name offset ) {
//===================================================
// Perform indexing operation.
offset = CGBinary( O_TIMES, offset, ArrayEltSize( arr ), TY_INT_4 );
XPush( SymIndex( arr, offset ) );
}
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 ) );
}
}
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 ) );
}
cg_name CgOffsetExpr( // MAKE OFFSET EXPRESSION
cg_name expr, // - lhs expression
target_offset_t offset, // - offset
cg_type type ) // - resultant type
{
if( offset == 0 ) {
expr = CGUnary( O_CONVERT, expr, type );
} else {
expr = CGBinary( O_PLUS, expr, CgOffset( offset ), type );
}
return expr;
}
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 ) ) );
}
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 ) ) );
}
}
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 );
}
static cg_name cgCommaSideEffect( // CONSTRUCT COMMA/SIDE-EFFECT EXPRESSION
cg_name lhs, // - expression on left
cg_name rhs, // - expression on right
cg_type type, // - type of right expression
cg_op opcode ) // - type of opcode
{
cg_name expr; // - result
if( NULL == lhs ) {
expr = rhs;
} else if( NULL == rhs ) {
expr = lhs;
} else {
expr = CGBinary( opcode, lhs, rhs, type );
}
return expr;
}
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 ) );
}
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 );
}
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 ) );
}
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 ) );
}
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 );
}
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 ) );
}
}
