static void ChkExtendFmt( void ) {
//==============================
if( Options & OPT_EXTEND_FORMAT ) {
OutU16( 1 );
} else {
OutU16( 0 );
}
}
void GPassLabel( label_id label, RTCODE routine ) {
//==================================================
// Pass the label identifying encoded format string.
// Called when using
// PRINT <constant character expression>, ...
EmitOp( FC_PASS_LABEL );
OutU16( routine );
OutU16( label );
}
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 GBegCall( itnode *itptr ) {
//=================================
// Initialize for subprogram invocation.
sym_id sp;
obj_ptr curr_obj;
int num_args;
sp = itptr->sym_ptr;
#if _CPU == 386
{
aux_info *aux;
aux = AuxLookupName( sp->u.ns.name, sp->u.ns.u2.name_len );
if( aux != NULL ) {
if( aux->cclass & FAR16_CALL ) {
if( (SubProgId->u.ns.flags & SY_SUBPROG_TYPE) == SY_PROGRAM ) {
ProgramInfo.cclass |= THUNK_PROLOG;
} else {
aux = AuxLookupAdd( SubProgId->u.ns.name, SubProgId->u.ns.u2.name_len );
aux->cclass |= THUNK_PROLOG;
}
}
}
}
#endif
EmitOp( FC_CALL );
OutPtr( itptr->sym_ptr );
curr_obj = ObjTell();
OutU16( 0 );
if( (Options & OPT_DESCRIPTOR) == 0 ) {
if( (sp->u.ns.flags & SY_SUBPROG_TYPE) == SY_FUNCTION ) {
if( (sp->u.ns.flags & SY_INTRINSIC) == 0 ) {
if( sp->u.ns.u1.s.typ == FT_CHAR ) {
OutPtr( GTempString( sp->u.ns.xt.size ) );
}
}
}
}
num_args = DumpArgInfo( itptr->list );
curr_obj = ObjSeek( curr_obj );
OutU16( num_args );
ObjSeek( curr_obj );
if( (sp->u.ns.flags & SY_SUBPROG_TYPE) == SY_FUNCTION ) {
if( sp->u.ns.u1.s.typ == FT_CHAR ) {
if( (Options & OPT_DESCRIPTOR) || (sp->u.ns.flags & SY_INTRINSIC) ) {
OutPtr( GTempString( sp->u.ns.xt.size ) );
}
}
}
}
void EmitOp( FCODE value ) {
//===================================
// Emit the specified F-Code.
OutU16( value );
}
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 );
}
warp_label GBegSList( void ) {
//===================================
// Generate code to start ADV initialization.
EmitOp( FC_FCODE_SEEK );
WarpLabel = ObjTell();
OutU16( 0 );
return( ObjTell() );
}
label_id GDataProlog( void ) {
//=============================
// Start off data statement code.
EmitOp( FC_START_DATA_STMT );
DtConstList = ObjTell();
OutU16( 0 );
return( 0 );
}
void OutInt( inttarg val ) {
//=============================
// Output target integer value to object memory.
#if _CPU == 8086
OutU16( val );
#else // _CPU == 386
OutConst32( val );
#endif
}
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 GBegDList( void ) {
//===================
// Start list of data.
unsigned_16 const_offset;
obj_ptr curr_obj;
const_offset = ObjOffset( DtConstList );
curr_obj = ObjSeek( DtConstList );
OutU16( const_offset );
ObjSeek( curr_obj );
}
void EndFmt( void ) {
//================
// Finish format processing.
obj_ptr fmt_ptr;
unsigned_16 fmt_len;
fmt_len = ObjOffset( FormatList ) - sizeof( unsigned_16 );
fmt_ptr = ObjSeek( FormatList );
OutU16( fmt_len );
ObjSeek( fmt_ptr );
}
void GCheckEOF( label_id label ) {
//===================================
// Patch the label emitted by GNullEofStmt() to be the label at the end
// of the code of the ATEND statement.
obj_ptr curr_obj;
curr_obj = ObjSeek( AtEndFCode );
EmitOp( FC_SET_ATEND );
OutU16( label );
ObjSeek( curr_obj );
}
void StartFmt( cs_label fmt_label ) {
//======================================
// Start format processing.
obj_ptr new_fmt;
EmitOp( FC_FCODE_SEEK );
new_fmt = ObjTell();
OutU16( 0 );
OutObjPtr( FormatList );
FormatList = new_fmt;
if( StmtProc == PR_FMT ) {
if( fmt_label.st_label == NULL ) {
// FORMAT statement with no statement label
OutU16( 0 );
} else {
OutU16( fmt_label.st_label->st.address );
}
} else {
OutU16( fmt_label.g_label );
}
}
void GEndSList( sym_id sym ) {
//=======================================
// Finish off ADV initialization.
unsigned_16 warp_size;
sym = sym;
EmitOp( FC_WARP_RETURN );
warp_size = ObjOffset( WarpLabel ) - sizeof( unsigned_16 );
WarpLabel = ObjSeek( WarpLabel );
OutU16( warp_size );
ObjSeek( WarpLabel );
}
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 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 );
}
}
static void DoLoopEnd( void ) {
//===========================
// Generate code for end of DO-loops or implied-DO.
do_entry *doptr;
doptr = CSHead->cs_info.do_parms;
EmitOp( FC_DO_END );
OutPtr( doptr->do_parm );
OutPtr( doptr->increment );
if( doptr->increment == NULL ) {
OutConst32( doptr->incr_value );
} else {
OutPtr( doptr->iteration );
}
OutU16( CSHead->branch );
}
static int DumpArgInfo( itnode *node ) {
//===========================================
// Dump argument types.
int num_args;
unsigned_16 arg_info;
PTYPE parm_type;
PCODE parm_code;
#if _CPU == 386
aux_info *aux;
#endif
num_args = 0;
if( node != NULL ) {
for(;;) {
if( node->opr == OPR_COL )
break;
if( node->opr == OPR_RBR )
break;
if( node->opn.ds == DSOPN_PHI )
break;
if( node->opn.us != USOPN_STN ) {
parm_type = ParmType( node->typ, node->size );
parm_code = ParmClass( node );
#if _CPU == 386
if( (parm_code == PC_PROCEDURE) || (parm_code == PC_FN_OR_SUB) ) {
aux = AuxLookup( node->sym_ptr );
if( aux->cclass & FAR16_CALL ) {
parm_code |= PC_PROC_FAR16;
}
}
#endif
arg_info = _SetTypeInfo( parm_code, parm_type );
OutU16( arg_info );
++num_args;
}
node = node->link;
}
}
return( num_args );
}
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
}
void GDataItem( itnode *rpt ) {
//================================
// Generate a data item.
sym_id data;
intstar4 one;
if( rpt == NULL ) {
one = 1;
data = STConst( &one, FT_INTEGER, TypeSize( FT_INTEGER ) );
} else {
data = rpt->sym_ptr;
}
OutPtr( data );
if( CITNode->typ == FT_HEX ) {
OutU16( PT_NOTYPE );
} else {
GenType( CITNode );
}
OutPtr( CITNode->sym_ptr );
}
void GEndCall( itnode *itptr, int num_stmts ) {
//================================================
// Finish off a subprogram invocation.
itnode *arg;
if( num_stmts > 0 ) {
EmitOp( FC_ALT_RET );
OutU16( num_stmts );
arg = itptr->list;
for(;;) {
if( (arg->opn.us & USOPN_WHAT) == USOPN_STN ) {
GStmtAddr( arg->sym_ptr );
num_stmts--;
}
arg = arg->link;
if( num_stmts == 0 ) break;
}
} else if( (itptr->sym_ptr->u.ns.flags & SY_SUBPROG_TYPE) == SY_SUBROUTINE ) {
EmitOp( FC_EXPR_DONE );
}
SetOpn( itptr, 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 );
}
}