void GArg( void ) {
//==============
// Generate an argument for subprogram, subscript, or substring.
if( (CITNode->opn.us & USOPN_WHERE) == USOPN_SAFE ) {
if( (CITNode->opn.us & USOPN_FLD) &&
((CITNode->opn.us & USOPN_WHAT) == USOPN_ARR) &&
(CITNode->typ == FT_CHAR) ) {
EmitOp( FC_PASS_FIELD_CHAR_ARRAY );
OutPtr( CITNode->value.st.field_id );
OutPtr( GTempString( 0 ) );
}
return;
}
if( (CITNode->opn.us & USOPN_WHAT) == USOPN_SSR ) {
EmitOp( FC_PUSH_SCB_LEN );
} else if( (CITNode->opn.us & USOPN_WHAT) == USOPN_CON ) {
PushOpn( CITNode );
} else if( (CITNode->opn.us & USOPN_WHAT) == USOPN_ARR ) {
PushOpn( CITNode );
if( CITNode->typ == FT_CHAR ) {
EmitOp( FC_PASS_CHAR_ARRAY );
SymRef( CITNode );
OutPtr( GTempString( 0 ) );
}
} else {
PushOpn( CITNode );
}
}
void GFiniSS( itnode *sym_node, itnode *ss_node ) {
//====================================================
// Finish a substring operation.
if( sym_node->opn.us & USOPN_FLD ) {
PushOpn( sym_node );
EmitOp( FC_FIELD_SUBSTRING );
OutPtr( sym_node->sym_ptr );
if( sym_node->opn.us & USOPN_SS1 ) { // length known at compile-time
OutInt( sym_node->value.st.ss_size );
} else {
OutInt( 0 ); // we don't know the length
}
} else {
EmitOp( FC_SUBSTRING );
if( sym_node->opn.us & USOPN_SS1 ) { // length known at compile-time
OutPtr( NULL );
} else {
SymRef( sym_node ); // in case we need the length of SCB if
} // character*(*) and no upper bound specified
}
GenTypes( ss_node, ss_node->link );
if( (sym_node->opn.us & USOPN_FLD) == 0 ) {
if( sym_node->opn.us & USOPN_SS1 ) { // length known at compile-time
OutInt( sym_node->value.st.ss_size );
}
if( (StmtSw & SS_DATA_INIT) == 0 ) {
sym_node->value.st.ss_id = sym_node->sym_ptr;
sym_node->sym_ptr = GTempString( 0 );
OutPtr( sym_node->sym_ptr );
sym_node->opn.us |= USOPN_ASY;
}
}
}
void GEndSubScr( itnode *arr ) {
//=================================
// Finish off a subscripting operation.
itnode *arg;
int dim_cnt;
if( arr->opn.us & USOPN_FLD ) {
PushOpn( arr );
EmitOp( FC_FIELD_SUBSCRIPT );
OutPtr( arr->sym_ptr );
dim_cnt = _DimCount( arr->sym_ptr->u.fd.dim_ext->dim_flags );
} else {
EmitOp( FC_SUBSCRIPT );
OutPtr( arr->sym_ptr );
dim_cnt = _DimCount( arr->sym_ptr->u.ns.si.va.u.dim_ext->dim_flags );
}
arg = arr->list;
while( dim_cnt-- > 0 ) {
GenType( arg );
arg = arg->link;
}
if( ( arr->opn.us & USOPN_FLD ) == 0 ) {
if( ( StmtSw & SS_DATA_INIT ) == 0 ) {
if( arr->sym_ptr->u.ns.u1.s.typ == FT_CHAR ) {
OutPtr( GTempString( 0 ) );
}
}
}
SetOpn( arr, USOPN_SAFE );
}
void FieldOp( TYPE typ1, TYPE typ2, OPTR op ) {
//================================================
// Generate code for a field selection operator.
typ1 = typ1; op = op;
PushOpn( CITNode->link );
PushOpn( CITNode );
if( CITNode->opn.us & USOPN_FLD ) {
// sub-field reference
EmitOp( FC_ADD );
DumpTypes( FT_INTEGER, TypeSize( FT_INTEGER ),
FT_INTEGER, TypeSize( FT_INTEGER ) );
} else {
EmitOp( FC_FIELD_OP );
OutPtr( CITNode->sym_ptr );
if( ( StmtSw & SS_DATA_INIT ) == 0 ) {
if( typ2 == FT_CHAR ) {
if( ( CITNode->link->opn.us & USOPN_WHAT ) != USOPN_ARR ) {
if( ( ( CITNode->link->opn.us & USOPN_WHAT ) != USOPN_NWL ) &&
( ( CITNode->link->opn.us & USOPN_WHAT ) != USOPN_ASS ) ) {
GFieldSCB( CITNode->link->size );
}
EmitOp( FC_MAKE_SCB );
OutPtr( GTempString( 0 ) );
}
}
} else {
OutPtr( CITNode->link->sym_ptr );
}
}
}
void GNullEofStmt( void ) {
//======================
// Emit the "null" F-Code.
// If an ATEND statement follows, the "null" F-Code will be patched with a
// RT_SET_END F-Code.
AtEndFCode = ObjTell();
EmitOp( FC_NULL_FCODE );
EmitOp( FC_NULL_FCODE );
}
void GIOStructArray( void ) {
//========================
// Generate code to do structured array i/o.
if( StmtProc == PR_READ ) {
EmitOp( FC_STRUCT_INP_ARRAY );
} else {
EmitOp( FC_STRUCT_PRT_ARRAY );
}
OutPtr( CITNode->sym_ptr );
}
static void GIORoutine( TYPE typ, uint size ) {
//=================================================
FCODE op_code;
op_code = ParmType( typ, size ) - PT_LOG_1;
if( StmtProc == PR_READ ) {
EmitOp( op_code + FC_INP_LOG1 );
} else {
EmitOp( op_code + FC_OUT_LOG1 );
}
}
void GIOStruct( sym_id sd ) {
//==============================
// Generate code to do structure i/o.
PushOpn( CITNode );
if( StmtProc == PR_READ ) {
EmitOp( FC_INPUT_STRUCT );
} else {
EmitOp( FC_OUTPUT_STRUCT );
}
OutPtr( sd ); // structure definition
}
void AsgnChar( void ) {
//========================
// Perform character assignment.
itnode *save_cit;
uint num_args;
uint i;
uint j;
save_cit = CITNode;
AdvanceITPtr();
num_args = AsgnCat();
i = SrcChar( CITNode );
j = TargChar( save_cit );
if( ( num_args == 1 ) && ( i > 0 ) && ( j > 0 ) ) {
if( OptimalChSize( i ) && OptimalChSize( j ) && ( i == j ) ) {
PushOpn( save_cit );
EmitOp( FC_CHAR_1_MOVE );
DumpType( MapTypes( FT_INTEGER, i ), i );
GenChar1Op( CITNode );
if( ( CITNode->opn.us & USOPN_WHAT ) == USOPN_CON ) {
CITNode->sym_ptr->u.lt.flags &= ~LT_SCB_TMP_REFERENCE;
}
CITNode = save_cit;
} else {
#if ( _CPU == 386 || _CPU == 8086 )
if( j < i ) {
i = j;
}
CITNode = save_cit;
PushOpn( CITNode );
EmitOp( FC_CHAR_N_MOVE );
OutInt( i );
OutInt( j );
#else
CatArgs( num_args );
CITNode = save_cit;
PushOpn( CITNode );
EmitOp( FC_CAT );
OutU16( (uint_16)num_args );
#endif
}
} else {
CatArgs( num_args );
CITNode = save_cit;
PushOpn( CITNode );
EmitOp( FC_CAT );
OutU16( (uint_16)num_args );
}
}
void GSetIOCB( void ) {
//==================
// Generate a call to set the IOCB.
EmitOp( FC_SET_IOCB );
}
static void DataDoEnd( void ) {
//===========================
// Process end of implied-DO for DATA statement.
EmitOp( FC_END_OF_SEQUENCE );
}
void GForceHiBound( int ss, sym_id sym ) {
//=======================================================
// Generate code to fill in ADV subscript element (hi bound).
// The hi bound is constant and the low bound is not.
// We have to force the filling in of the high bound so that the number of
// of elements gets computed.
//
// Scenario: SUBROUTINE SAM( A, J )
// DIMENSION A(J:3)
//
// GInitADV() fills in the lo bound and # of elements in the dimension at
// compile-time. The lo bound is unknown so the ADV does not contain the
// correct information. The lo bound gets filled in at run-time but
// since the hi bound is not dumped into the ADV at compile time we
// must fill it in at run-time and compute the correct number of elements
// in the dimension.
AddConst( CITNode );
PushOpn( CITNode );
EmitOp( FC_ADV_FILL_HI );
OutPtr( sym );
OutU16( (uint_16)ss );
GenType( CITNode );
}
void PushOpn( itnode *itptr ) {
//================================
// Generate a push of an operand.
// Also called for target of character assignment.
unsigned_16 flags;
TYPE typ;
USOPN what;
USOPN where;
where = itptr->opn.us & USOPN_WHERE;
if( ( itptr->opn.ds != DSOPN_PHI ) && ( where != USOPN_SAFE ) ) {
typ = itptr->typ;
flags = itptr->flags;
what = itptr->opn.us & USOPN_WHAT;
if( where != 0 ) {
EmitOp( FC_PUSH );
SymRef( itptr );
} else if( itptr->opn.us & USOPN_FLD ) {
PushConst( itptr->value.intstar4 );
} else if( ( flags & SY_CLASS ) == SY_SUBPROGRAM ) {
// 1. it's a statement function
// 2. it's a subprogram passed as an argument
EmitOp( FC_PUSH );
SymRef( itptr );
} else if( what == USOPN_CON ) {
if( typ == FT_CHAR ) {
EmitOp( FC_PUSH_LIT );
if( itptr->sym_ptr->u.lt.flags & LT_SCB_TMP_REFERENCE ) {
itptr->sym_ptr->u.lt.flags |= LT_SCB_REQUIRED;
} else {
// in case string optimizations use value directly,
// LT_SCB_TMP_REFERENCE will be turned off
itptr->sym_ptr->u.lt.flags |= LT_SCB_TMP_REFERENCE;
}
} else {
EmitOp( FC_PUSH_CONST );
}
SymRef( itptr );
} else {
EmitOp( FC_PUSH );
SymRef( itptr );
}
SetOpn( itptr, USOPN_SAFE );
}
}
void PushConst( intstar4 val ) {
//=================================
// Push an integer constant.
EmitOp( FC_PUSH_CONST );
OutPtr( STConst( &val, FT_INTEGER, TypeSize( FT_INTEGER ) ) );
}
void GSetNameList( FCODE routine ) {
//=====================================
// Pass the address of NAMELIST data for run-time routine.
EmitOp( routine );
OutPtr( CITNode->sym_ptr );
}
void GPassAddr( FCODE routine ) {
//==================================
// Pass the address of CITNode on the stack and emit fcode for routine.
PushOpn( CITNode );
EmitOp( routine );
}
void GIntlSet( void ) {
//==================
// Set internal file pointer to character variable.
PushOpn( CITNode );
EmitOp( FC_SET_INTL );
}
void GStartIO( void ) {
//==================
// Generate code to invoke the run-time routine.
if( !AuxIOStmt() && NotFormatted() ) {
EmitOp( FC_SET_NOFMT );
}
EmitOp( FC_IO_STMTS + IOIndex() );
// PRINT, READ and WRITE i/o statements can check for END= and ERR=
// statement labels when RT_ENDIO is generated; auxilliary i/o
// statements don't generate RT_ENDIO so generate F-Code to check
// for statement labels.
if( AuxIOStmt() || Already( IO_NAMELIST ) ) {
EmitOp( FC_CHK_IO_STMT_LABEL );
}
}
void TDStmtFini( void ) {
//============================
// Target dependent statement finalization.
if( StmtProc == PR_ASNMNT ) {
if( TypeCmplx( ResultType ) ) {
EmitOp( FC_CMPLX_EXPR_DONE );
} else {
EmitOp( FC_EXPR_DONE );
}
}
if( StmtSw & SS_SF_REFERENCED ) {
EmitOp( FC_SF_REFERENCED );
}
EmitOp( FC_STMT_DONE );
}
void GFieldSCB( inttarg size ) {
//=================================
// Setup an SCB for a character field.
PushConst( size );
EmitOp( FC_FLIP );
}
void GEndVarSet( void ) {
//====================
// Terminate set of variables (i.e. Data i,j,k/1,2,3/,m/3/ - i,j,k is a set
// and m is a set).
EmitOp( FC_END_VAR_SET );
}
static void FinishCALL( itnode *sp ) {
//========================================
if( (sp->sym_ptr->u.ns.flags & SY_SUBPROG_TYPE) == SY_FUNCTION ) {
// a FUNCTION invoked in a CALL statement
EmitOp( FC_EXPR_DONE );
}
}
void GIOArray( void ) {
//==================
// Generate code to do array i/o.
if( StmtProc == PR_READ ) {
EmitOp( FC_INP_ARRAY );
} else {
EmitOp( FC_PRT_ARRAY );
}
OutPtr( CITNode->sym_ptr );
if( CITNode->opn.us & USOPN_FLD ) {
OutPtr( CITNode->value.st.field_id );
} else {
OutPtr( NULL );
}
}
void GWarp( sym_id sym ) {
//===================================
// Generate warp to code to fill in ADV.
EmitOp( FC_WARP );
OutPtr( sym );
}
void GEndBlockData( void ) {
//=======================
// Terminate a block data subprogram.
EmitOp( FC_EPILOGUE );
OutPtr( SubProgId );
}
void GArrIntlSet( void ) {
//=====================
// Set internal file pointer to array.
EmitOp( FC_ARR_SET_INTL );
OutPtr( CITNode->sym_ptr );
OutPtr( GTempString( 0 ) );
}
void GNullRetIdx( void ) {
//=====================
// No alternate return.
PushConst( 0 );
EmitOp( FC_ASSIGN_ALT_RET );
DumpType( FT_INTEGER, TypeSize( FT_INTEGER ) );
}
void GRetIdx( void ) {
//=================
// Generate an alternate return.
PushOpn( CITNode );
EmitOp( FC_ASSIGN_ALT_RET );
GenType( CITNode );
}
warp_label GBegSList( void ) {
//===================================
// Generate code to start ADV initialization.
EmitOp( FC_FCODE_SEEK );
WarpLabel = ObjTell();
OutU16( 0 );
return( ObjTell() );
}
static void GCnvTo( TYPE typ, uint size ) {
//=============================================
// Convert operand.
EmitOp( FC_CONVERT );
DumpTypes( CITNode->typ, CITNode->size, typ, size );
CITNode->typ = typ;
CITNode->size = size;
}
