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 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 );
}
}
tVoid PrintArgs( int argc , char** argv )
{
int idx ;
for( idx = 0 ; idx < argc ; idx++ )
{
OutInt( idx , sizeof( idx ) ) ;
OutString( " : " ) ;
OutString( argv[ idx ] ) ;
OutLinefeed() ;
}
}
void R_FOG( void ) {
//===============
int width;
int dec;
int exp;
int logval;
char *buf;
ftnfile *fcb;
char ch;
extended value;
extended absvalue;
width = IOCB->fmtptr->fmt3.fld1;
dec = IOCB->fmtptr->fmt3.fld2;
exp = IOCB->fmtptr->fmt3.fld3;
fcb = IOCB->fileinfo;
buf = &fcb->buffer[ fcb->col ];
if( IOCB->typ <= PT_LOG_4 ) {
R_FOLog();
} else if( IOCB->typ <= PT_INT_4 ) {
OutInt( width, 1 );
} else {
if( GetRealRtn( &value, width ) ) {
absvalue = value;
if( value < 0.0 ) {
absvalue = -value;
}
/* round to "dec" digits */
absvalue = absvalue + .5 * pow( 10, -dec );
if( ( IOCB->typ == PT_REAL_4 ) || ( IOCB->typ == PT_CPLX_8 ) ) {
logval = Div10S( absvalue );
} else if((IOCB->typ == PT_REAL_8) || (IOCB->typ == PT_CPLX_16)) {
logval = Div10L( absvalue );
} else {
logval = Div10X( absvalue );
}
// use E format if less than 0.1 unless value is zero
// use E format if there are more digits than the width
if( (( absvalue < 0.1 ) || ( logval >= dec )) &&
( value != 0.0 ) ) {
ch = 'E';
if( exp == 0 ) { // if Gw.d
#if defined( _M_IX86 ) || defined( __AXP__ ) || defined( __PPC__ )
if( ( ( absvalue <= P1d_99 ) || ( absvalue >= P1d100 ) ) &&
( absvalue != 0.0 ) ) {
ch = NULLCHAR; // no exponent letter
exp = 3;
} else {
#endif
exp = 2;
#if defined( _M_IX86 ) || defined( __AXP__ ) || defined( __PPC__ )
}
#endif
}
R_F2E( value, buf, width, dec, (IOCB->flags & IOF_PLUS) != 0,
IOCB->scale, exp, ch );
fcb->col += width;
} else {
if( exp == 0 ) { // if Gw.d
exp = 4;
} else {
exp += 2;
}
width -= exp;
if( width > 0 ) {
dec -= ( logval + 1 );
if( ( dec <= width ) && ( dec >= 0 ) ) {
R_F2F( value, buf, width, dec,
( IOCB->flags & IOF_PLUS ) != 0, 0 );
fcb->col += width;
if( *buf == '*' ) {
// fill remaining field
SendChar( '*', exp );
} else {
SendChar( ' ', exp );
}
} else {
SendChar( '*', width + exp );
}
} else {
SendChar( '*', width + exp );
}
}
} else { // undefined chars will be filled in for value
fcb->col += width;
}
}
}
void R_FOInt( void ) {
//=================
OutInt( IOCB->fmtptr->fmt2.fld1, IOCB->fmtptr->fmt2.fld2 );
}
