static intstar4 CheckSubscr( act_eq_entry *eqv_entry ) {
//==============================================================
// Check that array is properly subscripted.
sym_id sym;
act_dim_list *dims;
int dims_no;
intstar4 offset;
sym = eqv_entry->name_equived;
dims_no = 0;
if( sym->ns.flags & SY_SUBSCRIPTED ) {
dims = sym->ns.si.va.dim_ext;
dims_no = _DimCount( dims->dim_flags );
dims->dim_flags &= ~DIM_PVD;
}
if( eqv_entry->subs_no == 0 ) {
offset = 0;
} else if( dims_no != eqv_entry->subs_no ) {
if( eqv_entry->subs_no == 1 ) {
offset = eqv_entry->subscrs[0] - 1;
} else {
offset = 0;
NameStmtErr( EV_SSCR_INVALID, sym, PR_EQUIV );
}
} else if( !DoSubscript( dims, eqv_entry->subscrs, &offset ) ) {
offset = 0;
NameStmtErr( EV_SSCR_INVALID, sym, PR_EQUIV );
}
return( offset * _SymSize( sym ) );
}
static void SetHigh( sym_id sym ) {
//=====================================
// Set the high extent of a symbol which hasn't been put in an equivalence
// set.
sym->ns.si.va.vi.ec_ext->high = _SymSize( sym );
if( sym->ns.flags & SY_SUBSCRIPTED ) {
sym->ns.si.va.vi.ec_ext->high *= sym->ns.si.va.dim_ext->num_elts;
}
}
cg_name ArrayEltSize( sym_id arr ) {
//==================================
// Get element size of an array.
cg_name elt_size;
uint size;
size = _SymSize( arr );
if( size == 0 ) { // character*(*) array
elt_size = CharItemLen( arr );
} else {
elt_size = CGInteger( size, TY_INTEGER );
}
return( elt_size );
}
void DtSubscript( void ) {
//=====================
// Data initialize an array element.
intstar4 offset;
InitVar = GetPtr();
if( !Subscript( InitVar->u.ns.si.va.u.dim_ext, &offset ) ) {
NameStmtErr( EV_SSCR_INVALID, InitVar, PR_DATA );
}
DtOffset = offset * _SymSize( InitVar );
if( InitVar->u.ns.u1.s.typ != FT_STRUCTURE ) {
DtItemSize = InitVar->u.ns.xt.size;
}
}
void DtInpArray( void ) {
//====================
// Data initialize an array.
sym_id fd;
sym_id sym;
sym = GetPtr();
fd = GetPtr();
if( fd == NULL ) {
InitVar = sym;
DtOffset = 0;
InitArr( sym->u.ns.si.va.u.dim_ext, sym->u.ns.u1.s.typ, _SymSize( sym ) );
} else { // array field within structure
InitArr( fd->u.fd.dim_ext, fd->u.fd.typ, fd->u.fd.xt.size );
}
}
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 ) );
}
cg_type SymPtrType( sym_id sym ) {
//================================
// Get type of pointer required to address given symbol.
sym_id leader;
cg_type p_type;
signed_32 offset;
com_eq *ce_ext;
unsigned_32 item_size;
segment_id leader_seg;
unsigned_16 flags;
flags = sym->ns.flags;
if( flags & SY_SUB_PARM ) {
// subprogram argument
if( ( flags & SY_CLASS ) == SY_SUBPROGRAM ) {
p_type = TY_CODE_PTR;
} else if( flags & SY_SUBSCRIPTED ) {
p_type = ArrayPtrType( sym );
} else {
p_type = TY_GLOBAL_POINTER;
}
} else if( flags & SY_IN_EQUIV ) {
leader = sym;
offset = 0;
for(;;) {
ce_ext = leader->ns.si.va.vi.ec_ext;
if( ce_ext->ec_flags & LEADER ) break;
offset += ce_ext->offset;
leader = ce_ext->link_eqv;
}
if( ce_ext->ec_flags & MEMBER_IN_COMMON ) {
offset += ce_ext->offset;
if( GetComBlkSize( ce_ext->com_blk ) <= MaxSegSize ) {
// common block fits in a segment
p_type = TY_GLOBAL_POINTER;
} else {
item_size = _SymSize( sym );
if( flags & SY_SUBSCRIPTED ) {
item_size *= sym->ns.si.va.dim_ext->num_elts;
}
if( offset + item_size <= MaxSegSize ) {
// object fits in first segment of common block
// (common block label is at start of first segment)
p_type = TY_GLOBAL_POINTER;
} else {
p_type = TY_HUGE_POINTER;
}
}
} else {
if( ce_ext->high - ce_ext->low <= MaxSegSize ) {
// equivalence set fits in a segment
p_type = TY_GLOBAL_POINTER;
} else {
item_size = _SymSize( sym );
if( flags & SY_SUBSCRIPTED ) {
item_size *= sym->ns.si.va.dim_ext->num_elts;
}
leader_seg = GetGlobalSeg( ce_ext->offset );
offset += ce_ext->offset;
if( ( GetGlobalSeg( offset ) == leader_seg ) &&
( GetGlobalSeg( offset + item_size ) == leader_seg ) ) {
// the entire item is in the same segment as the leader
p_type = TY_GLOBAL_POINTER;
} else {
p_type = TY_HUGE_POINTER;
}
}
}
} else if( flags & SY_IN_COMMON ) {
ce_ext = sym->ns.si.va.vi.ec_ext;
if( GetComBlkSize( ce_ext->com_blk ) <= MaxSegSize ) {
// common block fits in a segment
p_type = TY_GLOBAL_POINTER;
} else {
item_size = _SymSize( sym );
if( flags & SY_SUBSCRIPTED ) {
item_size *= sym->ns.si.va.dim_ext->num_elts;
}
if( ce_ext->com_blk->ns.flags & SY_EQUIVED_NAME ) {
if( ce_ext->offset + item_size <= MaxSegSize ) {
// object fits in first segment of common block
// (common block label is at start of first segment)
p_type = TY_GLOBAL_POINTER;
} else {
p_type = TY_HUGE_POINTER;
}
} else {
// each symbol in common block gets a label at the offset into
// the common block
if( GetComOffset( ce_ext->offset ) + item_size <= MaxSegSize ) {
// object fits in a segment
p_type = TY_GLOBAL_POINTER;
} else {
p_type = TY_HUGE_POINTER;
}
}
}
} else if( ( flags & SY_SUBSCRIPTED ) && _Allocatable( sym ) ) {
p_type = ArrayPtrType( sym );
} else if( ( flags & SY_SUBSCRIPTED ) || ( sym->ns.typ == FT_STRUCTURE ) ) {
item_size = _SymSize( sym );
if( flags & SY_SUBSCRIPTED ) {
item_size *= sym->ns.si.va.dim_ext->num_elts;
}
if( item_size > MaxSegSize ) {
p_type = TY_HUGE_POINTER;
} else if( item_size <= DataThreshold ) {
p_type = TY_LOCAL_POINTER;
} else {
p_type = TY_GLOBAL_POINTER;
}
} else {
p_type = TY_LOCAL_POINTER;
}
return( p_type );
}