cg_name CgAddrSymbol( // PASS ADDR OF SYMBOL TO CODE GENERATOR
SYMBOL sym ) // - symbol
{
#if 0
return CGFEName( (cg_sym_handle)sym, CgTypePtrSym( sym ) );
#else
return CGFEName( (cg_sym_handle)sym, CgTypeSym( sym ) );
#endif
}
static cg_name CharArrLength( sym_id sym ) {
//==========================================
// Get element size for character*(*) arrays.
if( sym->u.ns.flags & SY_VALUE_PARM ) {
return( CGInteger( 0, TY_INTEGER ) );
} else if( Options & OPT_DESCRIPTOR ) {
return( SCBLength( CGUnary( O_POINTS, CGFEName( sym, TY_POINTER ), TY_POINTER ) ) );
} else {
return( CGUnary( O_POINTS, CGFEName( FindArgShadow( sym ), TY_INTEGER ), TY_INTEGER ) );
}
}
void MakeSCB( sym_id scb, cg_name len ) {
//==========================================
// Make an SCB.
CGTrash( CGAssign( SCBLenAddr( CGFEName( scb, TY_CHAR ) ), len, TY_INTEGER ) );
// assumption is that the pointer in the SCB is the first field in
// the SCB so that when we push the cg_name returned by CGAssign()
// it is a pointer to the SCB
XPush( CGLVAssign( SCBPtrAddr( CGFEName( scb, TY_CHAR ) ), XPop(), TY_POINTER ) );
// Don't do it the following way:
// CGTrash( CGAssign( SCBPtrAddr( CGFEName( scb, TY_CHAR ) ), XPop(), TY_POINTER ) );
// XPush( CGFEName( scb, TY_CHAR ) );
}
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 ) );
}
call_handle InitInlineCall( int rtn_id ) {
//============================================
// Initialize a call to a runtime routine.
#if _CPU == 386 || _CPU == 8086
sym_id sym;
inline_rtn __FAR *in_entry;
uint name_len;
if( !CreatedPragmas ) {
InitInlinePragmas();
}
in_entry = &InlineTab[ rtn_id ];
sym = in_entry->sym_ptr;
if( sym == NULL ) {
name_len = strlen( in_entry->name );
strcpy( SymBuff, in_entry->name );
sym = STAdd( SymBuff, name_len );
sym->u.ns.flags = SY_USAGE | SY_TYPE | SY_SUBPROGRAM | SY_FUNCTION;
sym->u.ns.u1.s.typ = FT_INTEGER_TARG;
sym->u.ns.xt.size = TypeSize( sym->u.ns.u1.s.typ );
sym->u.ns.u3.address = NULL;
in_entry->sym_ptr = sym;
in_entry->aux = AuxLookupName( in_entry->name, name_len );
}
return( CGInitCall( CGFEName( sym, in_entry->typ ), in_entry->typ, in_entry->sym_ptr ) );
#else
rtn_id = rtn_id;
return( 0 );
#endif
}
void FCIntlArrSet( void ) {
//======================
// Call runtime routine to set internal file to character array.
call_handle handle;
sym_id sym;
sym_id scb;
sym = GetPtr();
scb = GetPtr();
CGTrash( CGAssign( SCBLenAddr( CGFEName( scb, TY_POINTER ) ),
ArrayEltSize( sym ), TY_INTEGER ) );
CGTrash( CGAssign( SCBPtrAddr( CGFEName( scb, TY_POINTER ) ),
SymAddr( sym ), TY_POINTER ) );
handle = InitCall( RT_SET_INTL );
CGAddParm( handle, ArrayNumElts( sym ), TY_INT_4 );
CGAddParm( handle, CGFEName( scb, TY_POINTER ), TY_POINTER );
CGDone( CGCall( handle ) );
}
cg_name GetAdv( sym_id arr ) {
//============================
act_dim_list *dim_ptr;
dim_ptr = arr->u.ns.si.va.u.dim_ext;
if( dim_ptr->adv == NULL ) {
// ADV is allocated on the stack
return( CGFEName( FindAdvShadow( arr ), TY_ADV_ENTRY ) );
} else {
return( CGBackName( dim_ptr->adv, TY_ADV_ENTRY ) );
}
}
void FCSetSCBLen( void ) {
//=====================
// Fill scb length
sym_id scb;
cg_name len;
// Get general information
scb = GetPtr();
len = GetTypedValue();
CGTrash( CGAssign( SCBLenAddr( CGFEName( scb, TY_CHAR ) ), len, TY_INTEGER ) );
}
static cg_name getFlags( sym_id sym ) {
//======================================
int tlen;
cg_name fl;
cg_type typ;
if( sym->ns.flags & SY_SUBSCRIPTED ) {
typ = ArrayPtrType( sym );
tlen = BETypeLength( typ );
} else {
tlen = BETypeLength( T_CHAR );
typ = T_CHAR;
}
fl = StructRef( CGFEName( sym, typ ), tlen );
return( CGUnary( O_POINTS, fl, T_UINT_2 ) );
}
call_handle InitCall( RTCODE rtn_id ) {
//======================================
// Initialize a call to a runtime routine.
sym_id sym;
rt_rtn __FAR *rt_entry;
byte typ;
int name_len;
char __FAR *ptr;
rt_entry = &RtnTab[ rtn_id ];
sym = rt_entry->sym_ptr;
if( sym == NULL ) {
name_len = 0;
ptr = rt_entry->name;
while( *ptr != NULLCHAR ) {
SymBuff[ name_len ] = *ptr;
++name_len;
++ptr;
}
sym = STAdd( SymBuff, name_len );
sym->u.ns.flags = SY_USAGE | SY_TYPE | SY_SUBPROGRAM | SY_FUNCTION |
SY_RT_ROUTINE;
if( rt_entry->typ == FT_NO_TYPE ) {
sym->u.ns.u1.s.typ = FT_INTEGER_TARG;
} else {
sym->u.ns.u1.s.typ = rt_entry->typ;
}
sym->u.ns.xt.size = TypeSize( sym->u.ns.u1.s.typ );
sym->u.ns.u3.address = NULL;
sym->u.ns.si.sp.u.imp_segid = AllocImpSegId();
rt_entry->sym_ptr = sym;
}
typ = F772CGType( sym );
return( CGInitCall( CGFEName( sym, typ ), typ, rt_entry->sym_ptr ) );
}
void FCAssignedGOTOList( void ) {
//============================
// Perform assigned GOTO with list.
sel_handle s;
label_handle label;
sym_id sn;
sym_id var;
obj_ptr curr_obj;
var = GetPtr();
curr_obj = FCodeTell( 0 );
s = CGSelInit();
for(;;) {
sn = GetPtr();
if( sn == NULL ) break;
if( ( sn->u.st.flags & SN_IN_GOTO_LIST ) == 0 ) {
sn->u.st.flags |= SN_IN_GOTO_LIST;
label = GetStmtLabel( sn );
CGSelCase( s, label, sn->u.st.address );
}
}
label = BENewLabel();
CGSelOther( s, label );
CGSelect( s, CGUnary( O_POINTS, CGFEName( var, TY_INTEGER ), TY_INTEGER ) );
CGControl( O_LABEL, NULL, label );
BEFiniLabel( label );
FCodeSeek( curr_obj );
for(;;) {
sn = GetPtr();
if( sn == NULL ) break;
sn->u.st.flags &= ~SN_IN_GOTO_LIST;
RefStmtLabel( sn );
}
}
void FCAllocate( void ) {
//============================
call_handle handle;
sym_id arr;
act_dim_list *dim;
uint num;
unsigned_16 alloc_flags;
cg_name expr_stat;
cg_name expr_loc;
cg_name fl;
label_handle label;
num = 0;
SymPush( NULL );
for(;;) {
arr = GetPtr();
if( arr == NULL ) break;
// check if array is already allocated before filling in ADV
label = BENewLabel();
fl = getFlags( arr );
fl = CGBinary( O_AND, fl, CGInteger( ALLOC_MEM, T_UINT_2 ), T_UINT_2 );
CGControl( O_IF_TRUE, CGCompare( O_NE, fl,
CGInteger( 0, T_UINT_2 ), T_UINT_2 ), label );
FCodeSequence(); // fill in the ADV, SCB or RCB
CGControl( O_LABEL, NULL, label );
BEFiniLabel( label );
SymPush( arr );
++num;
}
alloc_flags = GetU16();
if( alloc_flags & ALLOC_NONE ) {
expr_loc = CGInteger( 0, T_POINTER );
} else {
FCodeSequence();
if( alloc_flags & ALLOC_LOC ) {
expr_loc = XPopValue( T_INT_4 );
if( alloc_flags & ALLOC_STAT ) {
FCodeSequence();
expr_stat = XPop();
}
} else {
expr_stat = XPop();
}
}
handle = InitCall( RT_ALLOCATE );
for(;;) {
arr = SymPop();
if( arr == NULL ) break;
if( arr->ns.flags & SY_SUBSCRIPTED ) {
dim = arr->ns.si.va.dim_ext;
CGAddParm( handle, CGInteger( _SymSize( arr ), T_INT_4 ),
T_INT_4 );
CGAddParm( handle, CGInteger( _DimCount( dim->dim_flags ),
T_INTEGER ),
T_INTEGER );
CGAddParm( handle, GetAdv( arr ), T_LOCAL_POINTER );
}
CGAddParm( handle, CGFEName( arr, T_POINTER ), T_POINTER );
CGAddParm( handle, getFlags( arr ), FLAG_PARM_TYPE );
}
if( alloc_flags & ALLOC_NONE ) {
CGAddParm( handle, expr_loc, T_POINTER );
} else {
if( alloc_flags & ALLOC_LOC ) {
CGAddParm( handle, expr_loc, T_INT_4 );
}
if( alloc_flags & ALLOC_STAT ) {
CGAddParm( handle, expr_stat, T_POINTER );
}
}
CGAddParm( handle, CGInteger( num, T_INTEGER ), T_INTEGER );
CGAddParm( handle, CGInteger( alloc_flags, T_UINT_2 ), FLAG_PARM_TYPE );
CGDone( CGCall( handle ) );
}
void FCSFCall( void ) {
//==================
// Call a statement function.
sym_id sf;
sym_id sf_arg;
sym_id tmp;
cg_type sf_type;
cg_name arg_list;
cg_name value;
cg_cmplx z;
obj_ptr curr_obj;
sf = GetPtr();
arg_list = NULL;
value = NULL;
sf_type = 0;
for(;;) {
sf_arg = GetPtr();
if( sf_arg == NULL ) break;
if( sf_arg->u.ns.u1.s.typ == FT_CHAR ) {
value = Concat( 1, CGFEName( sf_arg, TY_CHAR ) );
} else {
sf_type = F772CGType( sf_arg );
if( TypeCmplx( sf_arg->u.ns.u1.s.typ ) ) {
XPopCmplx( &z, sf_type );
sf_type = CmplxBaseType( sf_type );
value = ImagPtr( SymAddr( sf_arg ), sf_type );
CGTrash( CGAssign( value, z.imagpart, sf_type ) );
value = CGFEName( sf_arg, sf_type );
value = CGAssign( value, z.realpart, sf_type );
} else {
value = CGFEName( sf_arg, sf_type );
value = CGAssign( value, XPopValue( sf_type ), sf_type );
}
}
if( arg_list == NULL ) {
arg_list = value;
} else {
arg_list = CGBinary( O_COMMA, arg_list, value, TY_DEFAULT );
}
}
if( sf->u.ns.u1.s.typ == FT_CHAR ) {
tmp = GetPtr();
value = CGUnary( O_POINTS, CGFEName( tmp, TY_CHAR ), TY_CHAR );
value = CGAssign( CGFEName( sf, TY_CHAR ), value, TY_CHAR );
if( arg_list == NULL ) {
arg_list = value;
} else {
arg_list = CGBinary( O_COMMA, arg_list, value, TY_DEFAULT );
}
value = CGFEName( tmp, TY_CHAR );
} else {
sf_type = F772CGType( sf );
if( !(OZOpts & OZOPT_O_INLINE) ) {
value = CGUnary( O_POINTS, CGFEName( sf, sf_type ), sf_type );
}
}
if( OZOpts & OZOPT_O_INLINE ) {
if( arg_list != NULL ) {
CGTrash( arg_list );
}
curr_obj = FCodeSeek( sf->u.ns.si.sf.u.sequence );
GetObjPtr();
FCodeSequence();
FCodeSeek( curr_obj );
if( sf->u.ns.u1.s.typ == FT_CHAR ) {
CGTrash( XPop() );
XPush( value );
} else if( TypeCmplx( sf->u.ns.u1.s.typ ) ) {
XPopCmplx( &z, sf_type );
sf_type = CmplxBaseType( sf_type );
XPush( TmpVal( MkTmp( z.imagpart, sf_type ), sf_type ) );
XPush( TmpVal( MkTmp( z.realpart, sf_type ), sf_type ) );
} else {
XPush( TmpVal( MkTmp( XPopValue( sf_type ), sf_type ), sf_type ) );
}
} else {
value = CGWarp( arg_list, GetLabel( sf->u.ns.si.sf.u.location ), value );
// consider: y = f( a, f( b, c, d ), e )
// make sure that inner reference to f gets evaluated before we assign
// arguments for outer reference
value = CGEval( value );
if( TypeCmplx( sf->u.ns.u1.s.typ ) ) {
SplitCmplx( TmpPtr( MkTmp( value, sf_type ), sf_type ), sf_type );
} else {
XPush( value );
}
RefStmtFunc( sf );
}
}
void FCSubString( void ) {
//=====================
// Do substring operation.
sym_id char_var;
sym_id dest;
cg_name src;
cg_name first_1;
cg_name first_2;
cg_name last;
unsigned_16 typ_info;
cg_name len;
cg_name ptr;
call_handle call;
char_var = GetPtr();
typ_info = GetU16();
src = XPop();
first_1 = XPopValue( GetType1( typ_info ) );
if( char_var == NULL ) { // i.e. chr(i:i)
len = CGInteger( GetInt(), TY_INTEGER );
if( Options & OPT_BOUNDS ) {
CloneCGName( first_1, &first_1, &last );
last = CGBinary( O_PLUS, last, len, TY_INTEGER );
last = CGBinary( O_MINUS, last, CGInteger( 1, TY_INTEGER ),
TY_INTEGER );
}
} else {
last = XPop();
if( last == NULL ) {
if( char_var->ns.xt.size == 0 ) {
last = CharItemLen( char_var );
} else {
last = CGInteger( char_var->ns.xt.size, TY_INTEGER );
}
} else {
XPush( last );
last = XPopValue( GetType2( typ_info ) );
}
if( !( Options & OPT_BOUNDS ) ) {
CloneCGName( first_1, &first_1, &first_2 );
len = CGBinary( O_MINUS, last, first_2, TY_INTEGER );
len = CGBinary( O_PLUS, len, CGInteger( 1, TY_INTEGER ), TY_INTEGER );
}
}
dest = GetPtr();
if( Options & OPT_BOUNDS ) {
call = InitCall( RT_SUBSTRING );
CGAddParm( call, CGFEName( dest, TY_CHAR ), TY_LOCAL_POINTER );
CGAddParm( call, last, TY_INT_4 );
CGAddParm( call, first_1, TY_INT_4 );
CGAddParm( call, src, TY_LOCAL_POINTER );
XPush( CGBinary( O_COMMA, CGCall( call ), CGFEName( dest, TY_CHAR ),
TY_LOCAL_POINTER ) );
} else {
ptr = CGBinary( O_PLUS, SCBPointer( src ),
CGBinary( O_MINUS, first_1, CGInteger( 1, TY_INTEGER ),
TY_INTEGER ),
TY_GLOBAL_POINTER );
CGTrash( CGAssign( SCBLenAddr( CGFEName( dest, TY_CHAR ) ),
len, TY_INTEGER ) );
// Assumption is that the pointer in the SCB is the first field in
// the SCB so that when we push the cg_name returned by CGAssign()
// it is a pointer to the SCB. We must leave the assignment of the
// pointer into the SCB in the tree so that the aliasing information
// is not lost.
XPush( CGLVAssign( SCBPtrAddr( CGFEName( dest, TY_CHAR ) ),
ptr, TY_GLOBAL_POINTER ) );
// Don't do it the following way:
// CGTrash( CGAssign( SCBPtrAddr( CGFEName( dest, TY_CHAR ) ),
// ptr, TY_GLOBAL_POINTER ) );
// XPush( CGFEName( dest, TY_CHAR ) );
}
}
cg_name CgSymbol( // PASS SYMBOL TO CODE GENERATOR
SYMBOL sym ) // - symbol
{
return CGFEName( (cg_sym_handle)sym, CgTypeSym( sym ) );
}
cg_name SymIndex( sym_id sym, cg_name i ) {
//=========================================
// Get address of symbol plus an index.
// Merges offset of symbols in common or equivalence with index so that
// we don't get two run-time calls for huge pointer arithmetic.
sym_id leader;
cg_name addr;
signed_32 offset;
com_eq *ce_ext;
cg_type p_type;
bool data_reference;
data_reference = TRUE;
if( ( sym->ns.flags & SY_CLASS ) == SY_SUBPROGRAM ) {
if( ( sym->ns.flags & SY_SUBPROG_TYPE ) == SY_STMT_FUNC ) {
addr = CGFEName( sym, F772CGType( sym ) );
} else {
addr = CGFEName( sym, TY_CODE_PTR );
if( sym->ns.flags & SY_SUB_PARM ) {
addr = CGUnary( O_POINTS, addr, TY_CODE_PTR );
}
data_reference = FALSE;
}
} else if( sym->ns.flags & SY_PS_ENTRY ) {
// it's the shadow symbol for function return value
if( CommonEntry == NULL ) {
if( sym->ns.typ == FT_CHAR ) {
if( Options & OPT_DESCRIPTOR ) {
addr = CGFEName( ReturnValue, F772CGType( sym ) );
addr = CGUnary( O_POINTS, addr, TY_POINTER );
} else {
addr = SubAltSCB( sym->ns.si.ms.sym );
}
} else {
addr = CGFEName( ReturnValue, F772CGType( sym ) );
}
} else {
if( (sym->ns.typ == FT_CHAR) && !(Options & OPT_DESCRIPTOR) ) {
addr = SubAltSCB( CommonEntry );
} else {
addr = CGUnary( O_POINTS, CGFEName( ReturnValue, TY_POINTER ),
TY_POINTER );
}
}
} else if( sym->ns.flags & SY_SUB_PARM ) {
// subprogram argument
if( sym->ns.flags & SY_SUBSCRIPTED ) {
p_type = ArrayPtrType( sym );
if( sym->ns.typ == FT_CHAR ) {
addr = CGUnary( O_POINTS, CGFEName( sym, p_type ), p_type );
if( !(sym->ns.flags & SY_VALUE_PARM) ) {
if( Options & OPT_DESCRIPTOR ) {
addr = SCBPointer( addr );
}
}
} else {
addr = CGUnary( O_POINTS, CGFEName( sym, p_type ), p_type );
}
} else {
p_type = TY_POINTER;
if( sym->ns.typ == FT_CHAR ) {
if( SCBRequired( sym ) ) {
addr = VarAltSCB( sym );
} else {
addr = CGUnary( O_POINTS, CGFEName( sym, p_type ), p_type );
}
} else if( sym->ns.flags & SY_VALUE_PARM ) {
p_type = F772CGType( sym );
if( TypeCmplx( sym->ns.typ ) ) {
p_type = CmplxBaseType( p_type );
addr = CGFEName( sym, p_type );
XPush( CGUnary( O_POINTS,
CGFEName( FindArgShadow( sym ), p_type ),
p_type ) );
addr = CGUnary( O_POINTS, addr, p_type );
} else {
addr = CGFEName( sym, p_type );
}
} else {
addr = CGUnary( O_POINTS, CGFEName( sym, p_type ), p_type );
}
}
} else if( sym->ns.flags & SY_IN_EQUIV ) {
leader = sym;
offset = 0;
for(;;) {
if( leader->ns.si.va.vi.ec_ext->ec_flags & LEADER ) break;
offset += leader->ns.si.va.vi.ec_ext->offset;
leader = leader->ns.si.va.vi.ec_ext->link_eqv;
}
if( leader->ns.si.va.vi.ec_ext->ec_flags & MEMBER_IN_COMMON ) {
addr = CGFEName( leader->ns.si.va.vi.ec_ext->com_blk,
F772CGType( sym ) );
offset += leader->ns.si.va.vi.ec_ext->offset;
} else {
sym_id shadow;
shadow = FindEqSetShadow( leader );
if( shadow != NULL ) {
addr = CGFEName( shadow, shadow->ns.si.ms.cg_typ );
offset -= leader->ns.si.va.vi.ec_ext->low;
} else if( (leader->ns.typ == FT_CHAR) &&
!(leader->ns.flags & SY_SUBSCRIPTED) ) {
addr = CGBackName( leader->ns.si.va.bck_hdl, F772CGType( sym ) );
} else {
addr = CGFEName( leader, F772CGType( sym ) );
}
}
if( i != NULL ) {
i = CGBinary( O_PLUS, i, CGInteger( offset, TY_INT_4 ), TY_INT_4 );
} else {
i = CGInteger( offset, TY_INT_4 );
}
addr = CGBinary( O_PLUS, addr, i, SymPtrType( sym ) );
if( (sym->ns.typ == FT_CHAR) && !(sym->ns.flags & SY_SUBSCRIPTED) ) {
// tell code generator where storage pointed to by SCB is located
addr = CGBinary( O_COMMA, addr,
CGFEName( sym, F772CGType( sym ) ), TY_DEFAULT );
}
i = NULL;
} else if( ( sym->ns.typ == FT_CHAR ) &&
( ( sym->ns.flags & SY_SUBSCRIPTED ) == 0 ) ) {
// character variable, address of scb
addr = CGFEName( sym, F772CGType( sym ) );
} else if( sym->ns.flags & SY_IN_COMMON ) {
ce_ext = sym->ns.si.va.vi.ec_ext;
if( i != NULL ) {
i = CGBinary( O_PLUS, i, CGInteger( ce_ext->offset, TY_INT_4 ),
TY_INT_4 );
} else {
i = CGInteger( ce_ext->offset, TY_INT_4 );
}
addr = CGBinary( O_PLUS, CGFEName( ce_ext->com_blk, F772CGType( sym ) ),
i, SymPtrType( sym ) );
i = NULL;
} else {
addr = CGFEName( sym, F772CGType( sym ) );
if( ( sym->ns.flags & SY_SUBSCRIPTED ) && _Allocatable( sym ) ) {
addr = CGUnary( O_POINTS, addr, ArrayPtrType( sym ) );
}
}
if( i != NULL ) {
addr = CGBinary( O_PLUS, addr, i, SymPtrType( sym ) );
}
if( ( OZOpts & OZOPT_O_VOLATILE ) && data_reference &&
( ( sym->ns.typ >= FT_REAL ) && ( sym->ns.typ <= FT_XCOMPLEX ) ) ) {
addr = CGVolatile( addr );
} else if( sym->ns.xflags & SY_VOLATILE ) {
addr = CGVolatile( addr );
}
return( addr );
}
