void FCWarpReturn( void ) {
//======================
// Return from a warp (array initialization).
FCodeSeek( WarpReturn );
}
void FCSeek( void ) {
//======================
// Seek to ObjPtr + offset.
FCodeSeek( FCodeTell( GetU16() ) );
}
void DtDataDoLoop( void ) {
//======================
// Process implied-DO for DATA statement.
intstar4 e2;
intstar4 e3;
intstar4 iter_count;
sym_id do_var;
obj_ptr curr_fc;
intstar4 e1;
e3 = DXPop();
e2 = DXPop();
e1 = DXPop();
do_var = GetPtr();
do_var->u.ns.si.ms.u.value = &e1;
iter_count = ( e2 - e1 + e3 ) / e3;
curr_fc = FCodeTell( 0 );
while( iter_count > 0 ) {
FCodeSeek( curr_fc );
FCodeSequence();
*do_var->u.ns.si.ms.u.value += e3;
iter_count--;
}
}
void DtEndDataStmt( void ) {
//=======================
// End DATA statement processing.
DtFiniSequence();
FCTablePtr = FCJmpTab;
FCodeSeek( DtConstList );
}
void FCWarp( void ) {
//================
// Process WARP F-Code.
sym_id arr;
warp_label init_label;
arr = GetPtr();
init_label = arr->u.ns.si.va.u.dim_ext->l.init_label;
WarpReturn = FCodeSeek( init_label );
}
static void GetDataConst( void ) {
//==============================
// Get a constant for data initialization.
obj_ptr curr_fc;
sym_id rep;
if( ( DtFlags & DT_NO_MORE_CONSTS ) == 0 ) {
if( DtRepCount == 0 ) {
curr_fc = FCodeSeek( DtConstList );
rep = GetPtr();
if( rep != NULL ) {
DtRepCount = IntegerValue( rep );
DtConstType = GetU16();
DtConst = GetPtr();
} else {
DtFlags |= DT_NO_MORE_CONSTS;
}
DtConstList = FCodeSeek( curr_fc );
}
DtRepCount--;
}
}
void FCStartSF( void ) {
//===========================
// Start definition of a statement function.
sym_id sf;
if( OZOpts & OZOPT_O_INLINE ) {
// skip the statement function
FCodeSeek( GetObjPtr() );
} else {
sf = GetPtr();
SFEndLabel = GetU16();
CGControl( O_GOTO, NULL, GetLabel( SFEndLabel ) );
CGControl( O_LABEL, NULL, GetLabel( sf->u.ns.si.sf.u.location ) );
}
}
void FCAssignedGOTOList( void ) {
//============================
// Perform assigned GOTO with list.
sel_handle s;
label_handle label;
sym_id sn;
sym_id var;
obj_ptr curr_obj;
var = GetPtr();
curr_obj = FCodeTell( 0 );
s = CGSelInit();
for(;;) {
sn = GetPtr();
if( sn == NULL ) break;
if( ( sn->u.st.flags & SN_IN_GOTO_LIST ) == 0 ) {
sn->u.st.flags |= SN_IN_GOTO_LIST;
label = GetStmtLabel( sn );
CGSelCase( s, label, sn->u.st.address );
}
}
label = BENewLabel();
CGSelOther( s, label );
CGSelect( s, CGUnary( O_POINTS, CGFEName( var, TY_INTEGER ), TY_INTEGER ) );
CGControl( O_LABEL, NULL, label );
BEFiniLabel( label );
FCodeSeek( curr_obj );
for(;;) {
sn = GetPtr();
if( sn == NULL ) break;
sn->u.st.flags &= ~SN_IN_GOTO_LIST;
RefStmtLabel( sn );
}
}
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 );
}
}