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 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 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 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 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 GArrIntlSet( void ) {
//=====================
// Set internal file pointer to array.
EmitOp( FC_ARR_SET_INTL );
OutPtr( CITNode->sym_ptr );
OutPtr( GTempString( 0 ) );
}
void GSFCall( itnode *sfunc ) {
//================================
// Generate a statement function call.
sf_parm *arg;
EmitOp( FC_SF_CALL );
OutPtr( sfunc->sym_ptr );
arg = sfunc->sym_ptr->ns.si.sf.header->parm_list;
while( arg != NULL ) {
OutPtr( arg->shadow );
arg = arg->link;
}
OutPtr( NULL );
if( sfunc->typ == FT_CHAR ) {
OutPtr( GTempString( sfunc->size ) );
}
SetOpn( sfunc, USOPN_SAFE );
}
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
}
