void CgExprDtored( // DTOR CG EXPRESSION
cg_name expr, // - expression
cg_type type, // - expression type
DGRP_FLAGS pop_type, // - type of popping destruction
FN_CTL* fctl ) // - function control
{
#if 0
cg_type type; // - expression type
switch( CgExprStackSize() ) {
case 0 :
break;
case 1 :
{ boolean temp_dtoring = fctl->temp_dtoring;
SYMBOL temp = getExprTempSym( &type, fctl, pop_type );
if( temp_dtoring ) {
if( fctl->ctor_test ) {
pop_type |= DGRP_CTOR;
}
CgDestructExprTemps( pop_type, fctl );
if( NULL != temp ) {
CgExprPush( CgFetchSym( temp ), type );
}
}
} break;
DbgDefault( "CgExprDtored -- too many temps" );
}
#else
SYMBOL temp; // - NULL or copied temp
DbgVerify( 0 == CgExprStackSize(), "CgExprDtored -- more than one expr" );
if( expr != NULL ) {
if( pop_type & DGRP_DONE ) {
CGDone( expr );
temp = NULL;
} else if( pop_type & DGRP_TRASH ) {
CGTrash( expr );
temp = NULL;
} else if( fctl->temp_dtoring ) {
temp = CgVarTempTyped( type );
CGDone( CGLVAssign( CgSymbol( temp ), expr, type ) );
} else {
CgExprPush( expr, type );
temp = NULL;
}
if( fctl->temp_dtoring ) {
fctl->temp_dtoring = FALSE;
if( fctl->ctor_test ) {
pop_type |= DGRP_CTOR;
}
CgDestructExprTemps( pop_type, fctl );
if( NULL != temp ) {
CgExprPush( CgFetchSym( temp ), type );
}
}
}
#endif
}
void FCAdvFillHi( void ) {
//=====================
// Fill hi bound of a dimension (actually computes # of elements in dimension).
sym_id arr;
act_dim_list *dim_ptr;
uint lo_size;
uint hi_size;
int hi_offset;
int ss;
cg_name num_elts;
cg_name hi;
cg_name adv;
call_handle call;
arr = GetPtr();
dim_ptr = arr->u.ns.si.va.u.dim_ext;
adv = GetAdv( arr );
hi_size = BETypeLength( TY_ADV_HI );
lo_size = BETypeLength( TY_ADV_LO );
ss = GetU16();
hi = GetTypedValue();
if( CGOpts & CGOPT_DI_CV ) {
hi_offset = _DimCount( dim_ptr->dim_flags ) * BETypeLength( TY_ADV_ENTRY );
if( Options & OPT_BOUNDS ) {
hi_offset += BETypeLength( TY_POINTER );
}
hi_offset += (ss - 1) * (lo_size + BETypeLength( TY_ADV_HI_CV )) + lo_size;
hi = CGAssign( StructRef( adv, hi_offset ), hi, TY_ADV_HI_CV );
adv = GetAdv( arr );
}
if( Options & OPT_BOUNDS ) {
call = InitCall( RT_ADV_FILL_HI );
CGAddParm( call, hi, TY_INT_4 );
CGAddParm( call, CGInteger( ss, TY_UNSIGNED ), TY_UNSIGNED );
CGAddParm( call, adv, TY_LOCAL_POINTER );
CGDone( CGUnary( O_POINTS, CGCall( call ), TY_INT_4 ) );
} else {
hi_offset = (ss - 1) * ( lo_size + hi_size ) + lo_size;
num_elts = CGBinary( O_PLUS, hi,
CGBinary( O_MINUS, CGInteger( 1, TY_INTEGER ),
LoBound( arr, ss - 1 ),
TY_ADV_HI ),
TY_ADV_HI );
CGDone( CGAssign( StructRef( adv, hi_offset ), num_elts, TY_ADV_HI ) );
}
}
void FCDeAllocate( void ) {
//==============================
call_handle handle;
sym_id arr;
uint num;
num = 0;
handle = InitCall( RT_DEALLOCATE );
for(;;) {
arr = GetPtr();
if( arr == NULL ) break;
CGAddParm( handle, CGFEName( arr, T_POINTER ), T_POINTER );
CGAddParm( handle, getFlags( arr ), FLAG_PARM_TYPE );
++num;
}
CGAddParm( handle, CGInteger( num, T_INTEGER ), T_INTEGER );
if( GetU16() & ALLOC_STAT ) {
FCodeSequence();
CGAddParm( handle, XPop(), T_POINTER );
} else {
CGAddParm( handle, CGInteger( 0, T_POINTER ), T_POINTER );
}
CGDone( CGCall( handle ) );
}
void FCDone( void ) {
//======================
// Process end of an expression.
CGDone( XPop() );
}
void FCCmplxDone( void ) {
//===========================
// Process end of a complex expression.
CGDone( CGBinary( O_COMMA, XPop(), XPop(), TY_DEFAULT ) );
}
void FCSetNoFmt( void ) {
//====================
// Set "not formatted i/o".
CGDone( CGCall( InitCall( RT_SET_NOFMT ) ) );
}
static void ChkIOErr( cg_name io_stat ) {
//===========================================
// Check for i/o errors.
label_handle eq_label;
io_stat = CGUnary( O_POINTS, io_stat, TY_INTEGER );
if( ( EndEqLabel != 0 ) && ( ErrEqLabel != 0 ) ) {
eq_label = BENewLabel();
CG3WayControl( io_stat, GetLabel( EndEqLabel ), eq_label,
GetLabel( ErrEqLabel ) );
CGControl( O_LABEL, NULL, eq_label );
BEFiniLabel( eq_label );
} else if( EndEqLabel != 0 ) {
CGControl( O_IF_TRUE,
CGCompare( O_LT, io_stat, CGInteger( 0, TY_INTEGER ),
TY_INTEGER ),
GetLabel( EndEqLabel ) );
} else if( ErrEqLabel != 0 ) {
CGControl( O_IF_TRUE,
CGCompare( O_NE, io_stat, CGInteger( 0, TY_INTEGER ),
TY_INTEGER ),
GetLabel( ErrEqLabel ) );
} else if( IOStatSpecified ) {
IOSLabel = BENewLabel();
CGControl( O_IF_TRUE,
CGCompare( O_NE, io_stat, CGInteger( 0, TY_INTEGER ),
TY_INTEGER ),
IOSLabel );
} else {
CGDone( io_stat );
}
}
void FCSetAtEnd( void ) {
//====================
// Set END= for ATEND statement.
CGDone( CGCall( InitCall( RT_SET_END ) ) );
EndEqLabel = GetU16();
}
static void IOString( RTCODE rtn ) {
//======================================
call_handle handle;
handle = InitCall( rtn );
CGAddParm( handle, XPop(), TY_INTEGER );
CGAddParm( handle, XPop(), TY_POINTER );
CGDone( CGCall( handle ) );
}
void FCSetFmt( void ) {
//==================
// Set format string from FORMAT statement.
call_handle handle;
handle = InitCall( RT_SET_FMT );
CGAddParm( handle, CGBackName( (back_handle)GetStmtLabel( GetPtr() ), TY_POINTER ), TY_POINTER );
CGDone( CGCall( handle ) );
}
void FCAssign( void ) {
//==================
// Process ASSIGN statement.
sym_id stmt;
stmt = GetPtr();
if( stmt->u.st.flags & SN_FORMAT ) {
CGDone( CGAssign( SymAddr( GetPtr() ),
CGBackName( GetFmtLabel( stmt->u.st.address ),
TY_LOCAL_POINTER ),
TY_LOCAL_POINTER ) );
} else {
CGDone( CGAssign( SymAddr( GetPtr() ),
CGInteger( stmt->u.st.address, TY_INTEGER ),
TY_INTEGER ) );
RefStmtLabel( stmt );
}
}
static void IOCallValue( RTCODE rtn ) {
//=========================================
// Call i/o run-time routine with one argument.
call_handle handle;
handle = InitCall( rtn );
CGAddParm( handle, GetTypedValue(), TY_INT_4 );
CGDone( CGCall( handle ) );
}
static void IOCall( RTCODE rtn ) {
//====================================
// Call i/o run-time routine with one argument.
call_handle handle;
handle = InitCall( rtn );
CGAddParm( handle, XPop(), TY_POINTER );
CGDone( CGCall( handle ) );
}
void FCOutCHAR( void ) {
//===================
// Call runtime routine to output CHARACTER*n value.
call_handle handle;
handle = InitCall( RT_OUT_CHAR );
CGAddParm( handle, XPop(), TY_POINTER );
CGDone( CGCall( handle ) );
}
void FCPassLabel( void ) {
//=====================
// Pass label to run-time routine.
call_handle handle;
handle = InitCall( GetU16() );
CGAddParm( handle, CGBackName( (back_handle)GetLabel( GetU16() ), TY_POINTER ), TY_POINTER );
CGDone( CGCall( handle ) );
}
static void Input( RTCODE rtn ) {
//===================================
// Common input routine.
call_handle handle;
handle = InitCall( rtn );
CGAddParm( handle, XPop(), TY_POINTER );
CGDone( CGCall( handle ) );
}
static void Output( RTCODE rtn, cg_type arg_type ) {
//======================================================
// Call runtime routine to output elemental types value.
call_handle handle;
handle = InitCall( rtn );
CGAddParm( handle, XPopValue( arg_type ), PromoteToBaseType( arg_type ) );
CGDone( CGCall( handle ) );
}
void FCAdvFillHiLo1( void ) {
//========================
// Fill hi and lo=1 bound of a dimension.
sym_id arr;
cg_name lo;
cg_name hi;
cg_name adv;
unsigned ss;
uint lo_size;
uint hi_size;
int lo_offset;
int hi_offset;
call_handle call;
// Get general information
arr = GetPtr();
ss = GetU16();
adv = GetAdv( arr );
hi_size = BETypeLength( TY_ADV_HI );
lo_size = BETypeLength( TY_ADV_LO );
hi = GetTypedValue();
if( Options & OPT_BOUNDS ) {
call = InitCall( RT_ADV_FILL_HI_LO1 );
CGAddParm( call, hi, TY_INT_4 );
CGAddParm( call, CGInteger( ss, TY_UNSIGNED ), TY_UNSIGNED );
CGAddParm( call, adv, TY_LOCAL_POINTER );
CGDone( CGUnary( O_POINTS, CGCall( call ), TY_INT_4 ) );
} else {
hi_offset = (ss - 1) * ( lo_size + hi_size ) + lo_size;
CGDone( CGAssign( StructRef( adv, hi_offset ), hi, TY_ADV_HI ) );
// set lo bound of the adv
lo = CGInteger( 1, TY_INT_4 );
lo_offset = (ss - 1) * BETypeLength( TY_ADV_ENTRY );
adv = GetAdv( arr );
CGDone( CGAssign( StructRef( adv, lo_offset ), lo, TY_ADV_LO ) );
}
}
void FCSetIntl( void ) {
//===================
// Call runtime routine to set internal file to character item (not array).
call_handle handle;
handle = InitCall( RT_SET_INTL );
CGAddParm( handle, CGInteger( 1, TY_INT_4 ), TY_INT_4 );
CGAddParm( handle, XPop(), TY_POINTER );
CGDone( CGCall( handle ) );
}
static void NumArrayIO( RTCODE rtn, cg_name arr, cg_name num_elts,
uint typ ) {
//====================================================================
call_handle call;
call = InitCall( rtn );
CGAddParm( call, CGInteger( typ, TY_INTEGER ), TY_INTEGER );
CGAddParm( call, num_elts, TY_INT_4 );
CGAddParm( call, arr, TY_POINTER );
CGDone( CGCall( call ) );
}
static void ChrArrayIO( RTCODE rtn, cg_name arr, cg_name num_elts,
cg_name elt_size ) {
//====================================================================
call_handle call;
call = InitCall( rtn );
CGAddParm( call, elt_size, TY_INTEGER );
CGAddParm( call, num_elts, TY_INT_4 );
CGAddParm( call, arr, TY_POINTER );
CGDone( CGCall( call ) );
}
void FCEndIO( void ) {
//=================
// Call runtime routine to terminate i/o processing.
CGDone( CGCall( InitCall( RT_ENDIO ) ) );
FCChkIOStmtLabel();
if( ( ErrEqLabel == 0 ) && ( EndEqLabel == 0 ) && IOStatSpecified ) {
CGControl( O_LABEL, NULL, IOSLabel );
BEFiniLabel( IOSLabel );
}
}
void FCFmtScan( void ) {
//===================
// Call runtime routine to scan a format specification from a character
// expression.
call_handle handle;
handle = InitCall( RT_FMT_SCAN );
CGAddParm( handle, CGInteger( GetU16(), TY_UNSIGNED ), TY_UNSIGNED );
CGAddParm( handle, XPop(), TY_POINTER );
CGDone( CGCall( handle ) );
}
static SYMBOL getExprTempSym( // EMIT CGDone, CGTrash, OR COPY TO TEMP
cg_name expr, // - expression
cg_type type, // - type of expression
FN_CTL* fctl, // - function control
DGRP_FLAGS pop_type ) // - type of popping destruction
{
SYMBOL temp; // - NULL or copied temp
if( pop_type & DGRP_DONE ) {
CGDone( expr );
temp = NULL;
} else if( pop_type & DGRP_TRASH ) {
CGTrash( expr );
temp = NULL;
} else if( fctl->temp_dtoring ) {
temp = CgVarTemp( BETypeLength( type ) );
CGDone( CGLVAssign( CgSymbol( temp ), expr, type ) );
} else {
temp = NULL;
}
fctl->temp_dtoring = FALSE;
return temp;
}
void FCFmtAssign( void ) {
//=====================
// Set FORMAT string for:
// ASSIGN 10 TO I
// PRINT I, ...
// 10 FORMAT( ... )
call_handle handle;
handle = InitCall( RT_SET_FMT );
CGAddParm( handle, CGUnary( O_POINTS, SymAddr( GetPtr() ), TY_POINTER ), TY_POINTER );
CGDone( CGCall( handle ) );
}
void FCSetLine( void ) {
//===================
// Generate run-time call to ISN routine.
call_handle handle;
unsigned_16 line_num;
line_num = GetU16();
if( ( SubProgId->ns.flags & SY_SUBPROG_TYPE ) == SY_BLOCK_DATA ) return;
handle = InitCall( RT_SET_LINE );
CGAddParm( handle, CGInteger( line_num, TY_INTEGER ), TY_INTEGER );
CGDone( CGCall( handle ) );
}
static void OutCplx( RTCODE rtn, cg_type typ ) {
//===============================================
// Call runtime routine to input COMPLEX value.
call_handle handle;
cg_cmplx z;
handle = InitCall( rtn );
XPopCmplx( &z, typ );
typ = CmplxBaseType( typ );
CGAddParm( handle, z.imagpart, typ );
CGAddParm( handle, z.realpart, typ );
CGDone( CGCall( handle ) );
}
void FCSetEnd( void ) {
//==================
// Set END=.
sym_id sn;
CGDone( CGCall( InitCall( RT_SET_END ) ) );
sn = GetPtr();
// Don't call RefStmtLabel() for 'sn' yet since we will be referencing
// the label for error checking after an i/o operation. RefStmtLabel()
// may call DoneLabel() if this is the last reference to the statement
// label.
EndEqStmt = sn;
EndEqLabel = sn->st.address;
}
void FCFmtArrScan( void ) {
//======================
// Call runtime routine to scan a format specification from a character
// array.
call_handle handle;
sym_id sym;
sym = GetPtr();
handle = InitCall( RT_FMT_ARR_SCAN );
CGAddParm( handle, CGInteger( GetU16(), TY_UNSIGNED ), TY_UNSIGNED );
CGAddParm( handle, ArrayEltSize( sym ), TY_UNSIGNED );
CGAddParm( handle, ArrayNumElts( sym ), TY_INT_4 );
CGAddParm( handle, SymAddr( sym ), TY_POINTER );
CGDone( CGCall( handle ) );
}
void FCAdvFillLo( void ) {
//=====================
// Fill lo bound of a dimension.
sym_id arr;
int lo_offset;
cg_name adv;
cg_name lo;
unsigned ss;
arr = GetPtr();
adv = GetAdv( arr );
ss = GetU16();
lo = GetTypedValue();
lo_offset = (ss - 1) * BETypeLength( TY_ADV_ENTRY );
CGDone( CGAssign( StructRef( adv, lo_offset ), lo, TY_ADV_LO ) );
}