void FCImag( void ) {
//================
cg_name opn;
cg_type typ;
typ = CmplxBaseType( GetType( GetU16() ) );
opn = XPop();
if( TypePointer( CGType( opn ) ) ) {
XPush( CGUnary( O_POINTS, ImagPtr( opn, typ ), typ ) );
} else {
CGTrash( opn );
}
}
cg_name GetTypedValue( void ) {
//=======================
// Pop a CG-name from the stack (its value).
cg_name opn;
cg_type typ;
opn = XPop();
typ = GetType( GetU16() );
if( TypePointer( CGType( opn ) ) ) {
opn = CGUnary( O_POINTS, opn, typ );
}
return( opn );
}
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 ) );
}
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 FCDeAllocate( void ) {
//==============================
call_handle handle;
sym_id arr;
uint num;
handle = InitCall( RT_DEALLOCATE );
for( num = 0; (arr = GetPtr()) != NULL; ++num ) {
CGAddParm( handle, CGFEName( arr, TY_POINTER ), TY_POINTER );
CGAddParm( handle, getFlags( arr ), FLAG_PARM_TYPE );
}
CGAddParm( handle, CGInteger( num, TY_UNSIGNED ), TY_UNSIGNED );
if( GetU16() & ALLOC_STAT ) {
FCodeSequence();
CGAddParm( handle, XPop(), TY_POINTER );
} else {
CGAddParm( handle, CGInteger( 0, TY_POINTER ), TY_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 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 ) );
}
}
