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 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 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 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 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 GInitSS( itnode *itptr ) {
//================================
// Start a substring operation.
PushOpn( itptr );
}
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 );
}
static void ParenExpr( void ) {
//=================================
// Finish off evaluation of a parenthesized expression.
// don't evaluate constants enclosed in parentheses
// so that they can be folded. Consider: (3+4)+5
if( CITNode->opn.us != USOPN_CON ) {
// Consider: CHARACTER A
// IF( ('9') .NE. (A) ) CONTINUE
// make sure that we can optimize the character operation
if( CITNode->opn.us == USOPN_NNL ) {
if( CITNode->typ == FT_CHAR ) {
int ch_size;
ch_size = CITNode->size;
if( OptimalChSize( ch_size ) ) {
CITNode->value.st.ss_size = ch_size;
CITNode->opn.us |= USOPN_SS1;
}
}
}
PushOpn( CITNode );
GParenExpr();
}
BackTrack();
}
void FiniCat( void ) {
//=========================
// Finish concatenation.
int num;
sym_id result;
int size;
// Make sure we don't PushOpn() a constant expression
// in case it's for a PARAMETER constant
if( CITNode->opn.us == USOPN_CON ) {
FoldCatSequence( CITNode );
if( AError ) return;
} else {
GenCatOpn();
}
num = ScanCat( &size );
if( num != 1 ) {
PushOpn( CITNode );
result = GStartCat( num, size );
CatArgs( num );
CITNode->size = size;
GStopCat( num, result );
}
}
void GPassAddr( FCODE routine ) {
//==================================
// Pass the address of CITNode on the stack and emit fcode for routine.
PushOpn( CITNode );
EmitOp( routine );
}
void GIOItem( void ) {
//=================
// Generate code to process an i/o list item.
PushOpn( CITNode );
GIORoutine( CITNode->typ, CITNode->size );
}
static void GenCatOpn( void ) {
//===========================
if( CITNode->opn.us != USOPN_CON ) {
ChkConstCatOpn( CITNode->link );
PushOpn( CITNode );
}
}
void GIntlSet( void ) {
//==================
// Set internal file pointer to character variable.
PushOpn( CITNode );
EmitOp( FC_SET_INTL );
}
void GCallWithArgs( void ) {
//=======================
// Generate a CALL with arguments.
PushOpn( CITNode );
FinishCALL( CITNode );
}
void EmExprDone( void ) {
//====================
// Finish expression processing.
if( ASType & AST_CCR ) { // i.e. IF( .TRUE. )THEN
PushOpn( CITNode );
}
}
static void DoExpr( void ) {
//========================
// Evaluate a DO expression (e1, e2 or e3 ).
EatDoParm();
PushOpn( CITNode );
AdvanceITPtr();
}
void GRetIdx( void ) {
//=================
// Generate an alternate return.
PushOpn( CITNode );
EmitOp( FC_ASSIGN_ALT_RET );
GenType( CITNode );
}
static void ChkConstCatOpn( itnode *cat_opn ) {
//=================================================
if( cat_opn->opn.us == USOPN_CON ) {
FoldCatSequence( cat_opn );
if( !AError ) {
PushOpn( cat_opn );
}
}
}
static void EvalOpn( void ) {
//===============================
// Evaluate operand.
if( CITNode->opn.us == USOPN_CON ) {
AddConst( CITNode );
}
PushOpn( CITNode );
}
void GFmtExprSet( void ) {
//=====================
// Pass the label identifying encoded format string.
// Called when using
// PRINT <character expression>, ...
PushOpn( CITNode );
EmitOp( FC_FMT_SCAN );
ChkExtendFmt();
}
void GSLoBound( int ss, sym_id sym ) {
//===================================================
// Generate code to fill in ADV subscript element (lo bound).
PushOpn( CITNode );
EmitOp( FC_ADV_FILL_LO );
OutPtr( sym );
OutU16( (uint_16)ss );
GenType( CITNode );
}
void GPassValue( FCODE rtn ) {
//===============================
// Pass the value of CITNode on the stack and emit fcode for routine.
PushOpn( CITNode );
EmitOp( rtn );
if( ( rtn == FC_SET_UNIT ) || ( rtn == FC_SET_REC ) ||
( rtn == FC_SET_RECL ) || ( rtn == FC_SET_BLOCKSIZE ) ) {
GenType( CITNode );
}
}
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 GSHiBoundLo1( int ss, sym_id sym ) {
//======================================================
// Generate code to fill in ADV subscript element (hi bound).
// Set the low bound to 1.
// push high bound value
PushOpn( CITNode );
EmitOp( FC_ADV_FILL_HI_LO_1 );
// general information
OutPtr( sym );
OutU16( (uint_16)ss );
GenType( CITNode );
}
void LogOp( TYPE typ1, TYPE typ2, OPTR op ) {
//==============================================
// Generate code for a relational operator.
bool flip;
op -= OPTR_FIRST_LOGOP;
flip = FALSE;
if( ( ( CITNode->opn.us & USOPN_WHERE ) == USOPN_SAFE ) &&
( ( CITNode->link->opn.us & USOPN_WHERE ) != USOPN_SAFE ) ) {
flip = TRUE;
}
PushOpn( CITNode->link );
if( typ1 == TY_NO_TYPE ) { // unary
if( _IsTypeInteger( typ2 ) ) {
EmitOp( FC_BIT_NOT );
} else {
EmitOp( FC_NOT );
}
GenType( CITNode->link );
SetOpn( CITNode, USOPN_SAFE );
} else {
PushOpn( CITNode );
if( _IsTypeInteger( typ2 ) ) {
EmitOp( FC_BITOPS + op );
} else {
EmitOp( FC_LOGOPS + op );
}
if( flip ) {
GenTypes( CITNode->link, CITNode );
} else {
GenTypes( CITNode, CITNode->link );
}
}
}
void ExpOp( TYPE typ1, TYPE typ2, OPTR opr ) {
//===============================================
// Generate code to perform exponentiation.
if( UnaryMul( typ1, typ2 ) ) {
PushOpn( CITNode );
EmitOp( FC_UNARY_MUL );
GenType( CITNode );
OutU16( ITIntValue( CITNode->link ) );
SetOpn( CITNode, USOPN_SAFE );
} else {
BinOp( typ1, typ2, opr );
}
}
void GStopCat( uint num_args, sym_id result ) {
//===============================================
// Finish concatenation into a temporary.
/* unused parameters */ (void)result;
CITNode->sym_ptr = GTempString( CITNode->size );
CITNode->opn.us = USOPN_VAL;
// Push the address of a static SCB so that we can modify its
// length to correspond to the length concatenated so that
// CHARACTER*5 WORD
// PRINT,LEN('1'//WORD(1:3))
// prints 4 and not 6. The static SCB in this case initially
// contains the length 6 ( len('1') + len(word) ) since generally
// we don't know the length concatenated at compile time if WORD
// was indexed as WORD(I:J).
PushOpn( CITNode );
EmitOp( FC_CAT );
OutU16( (uint_16)( num_args | CAT_TEMP ) ); // indicate concatenating into a static temp
}
static void Unary( TYPE typ, OPTR opr ) {
//=======================================
// Generate code for unary plus or unary minus.
PushOpn( CITNode->link );
if( opr == OPTR_SUB ) { // unary minus
if( TypeCmplx( typ ) ) {
EmitOp( FC_CUMINUS );
} else {
EmitOp( FC_UMINUS );
}
GenType( CITNode->link );
} else if( ( _IsTypeInteger( CITNode->link->typ ) ) &&
( CITNode->link->size < sizeof( intstar4 ) ) ) {
// convert INTEGER*1 or INTEGER*2 to INTEGER*4
EmitOp( FC_CONVERT );
DumpTypes( CITNode->link->typ, CITNode->link->size, FT_INTEGER, sizeof( intstar4 ) );
}
SetOpn( CITNode, USOPN_SAFE );
}
static void DoLoop( TYPE do_type ) {
//=====================================
// Generate code for DO statement or implied-DO.
do_entry *doptr;
uint do_size;
intstar4 incr;
intstar4 limit;
sym_id loop_ctrl;
TYPE e1_type;
uint e1_size;
itnode *e2_node;
itnode *e3_node;
bool e2_const;
doptr = CSHead->cs_info.do_parms;
do_size = CITNode->sym_ptr->u.ns.xt.size;
doptr->do_parm = CITNode->sym_ptr; // save ptr to do variable
AdvanceITPtr(); // bump past the '='
EatDoParm(); // process e1
PushOpn( CITNode );
e1_type = CITNode->typ;
e1_size = CITNode->size;
AdvanceITPtr();
if( ReqComma() ) {
EatDoParm(); // process e2
e2_const = CITNode->opn.us == USOPN_CON;
PushOpn( CITNode );
e2_node = CITNode;
AdvanceITPtr();
e3_node = NULL;
if( RecComma() ) {
EatDoParm(); // process e3
e3_node = CITNode;
if( !AError ) {
if( (CITNode->opn.us == USOPN_CON) && _IsTypeInteger( do_type ) ) {
incr = GetIntValue( CITNode );
doptr->incr_value = incr;
doptr->increment = NULL;
if( (OZOpts & OZOPT_O_FASTDO) == 0 ) {
if( e2_const ) {
limit = GetIntValue( e2_node );
if( NeedIncrement( limit, incr, do_type ) ) {
PushOpn( CITNode );
doptr->increment = StaticAlloc( do_size, do_type );
}
} else {
PushOpn( CITNode );
doptr->increment = StaticAlloc( do_size, do_type );
}
}
} else {
PushOpn( CITNode );
doptr->increment = StaticAlloc( do_size, do_type );
}
AdvanceITPtr();
}
} else {
if( _IsTypeInteger( do_type ) ) {
doptr->increment = NULL;
doptr->incr_value = 1;
if( (OZOpts & OZOPT_O_FASTDO) == 0 ) {
if( e2_const ) {
limit = GetIntValue( e2_node );
if( NeedIncrement( limit, 1, do_type ) ) {
PushConst( 1 );
doptr->increment = StaticAlloc( do_size, do_type );
}
} else {
PushConst( 1 );
doptr->increment = StaticAlloc( do_size, do_type );
}
}
} else {
PushConst( 1 );
doptr->increment = StaticAlloc( do_size, do_type );
}
}
EmitOp( FC_DO_BEGIN );
OutPtr( doptr->do_parm );
OutPtr( doptr->increment );
if( doptr->increment == NULL ) { // INTEGER do-loop with constant incr
loop_ctrl = StaticAlloc( do_size, do_type );
OutConst32( doptr->incr_value );
OutPtr( loop_ctrl );
} else {
if( _IsTypeInteger( do_type ) ) {
loop_ctrl = StaticAlloc( do_size, do_type );
} else {
loop_ctrl = StaticAlloc( sizeof( intstar4 ), FT_INTEGER );
}
doptr->iteration = loop_ctrl;
OutPtr( loop_ctrl );
if( e3_node == NULL ) {
DumpType( FT_INTEGER, TypeSize( FT_INTEGER ) );
} else {
GenType( e3_node );
}
}
GenType( e2_node );
DumpType( e1_type, e1_size );
OutU16( CSHead->branch );
OutU16( CSHead->bottom );
}
}
static void Binary( TYPE typ1, TYPE typ2, OPTR opr ) {
//====================================================
// Generate code for binary operations.
bool flip;
bool associative;
FCODE op_code;
associative = FALSE;
if( ( opr == OPTR_ADD ) || ( opr == OPTR_MUL ) ) {
associative = TRUE;
}
flip = FALSE;
if( ( ( CITNode->opn.us & USOPN_WHERE ) == USOPN_SAFE ) &&
( ( CITNode->link->opn.us & USOPN_WHERE ) != USOPN_SAFE ) ) {
flip = TRUE;
}
op_code = opr - OPTR_FIRST_ARITHOP;
PushOpn( CITNode->link );
PushOpn( CITNode );
if( TypeCmplx( typ1 ) && TypeCmplx( typ2 ) ) {
op_code += FC_CC_BINOPS;
if( flip && !associative ) {
EmitOp( FC_CMPLX_FLIP );
}
} else if( TypeCmplx( typ1 ) ) {
if( flip ) {
if( associative ) {
op_code += FC_XC_BINOPS;
} else {
EmitOp( FC_XC_FLIP );
op_code += FC_CX_BINOPS;
}
} else {
op_code += FC_CX_BINOPS;
}
} else if( TypeCmplx( typ2 ) ) {
if( flip ) {
if( associative ) {
op_code += FC_CX_BINOPS;
} else {
EmitOp( FC_CX_FLIP );
op_code += FC_XC_BINOPS;
}
} else {
op_code += FC_XC_BINOPS;
}
} else {
op_code += FC_BINOPS;
if( flip && !associative ) {
EmitOp( FC_FLIP );
}
}
EmitOp( op_code );
if( flip && associative ) {
GenTypes( CITNode->link, CITNode );
} else {
GenTypes( CITNode, CITNode->link );
}
}