static uint SymClass( sym_id sym ) {
//======================================
unsigned_16 class;
unsigned_16 flags;
flags = sym->ns.flags;
class = flags & SY_CLASS;
if( class == SY_PARAMETER ) return( NAME_PARAMETER );
if( class == SY_COMMON ) return( NAME_COMMON );
if( class == SY_SUBPROGRAM ) {
if( flags & SY_INTRINSIC ) return( NAME_INTRINSIC );
flags &= SY_SUBPROG_TYPE;
if( flags == SY_FN_OR_SUB ) return( NAME_EXT_PROC );
return( flags >> SY_SUBPROG_IDX );
}
if( flags & SY_SUB_PARM ) return( NAME_ARGUMENT );
if( (flags & SY_SPECIAL_PARM) && !(StmtSw & SS_DATA_INIT) ) return( NAME_SF_DUMMY );
if( flags & SY_IN_COMMON ) return( NAME_COMMON_VAR );
if( flags & SY_SUBSCRIPTED ) {
if( _Allocatable( sym ) ) return( NAME_ALLOCATED_ARRAY );
return( NAME_ARRAY );
}
if( flags & SY_PS_ENTRY ) return( NAME_FUNCTION );
if( flags & SY_IN_EQUIV ) return( NAME_EQUIV_VAR );
return( NAME_VARIABLE );
}
static void CkFlags( void ) {
//=========================
if( ( InitVar->u.ns.flags & SY_CLASS ) != SY_VARIABLE ) {
ClassNameErr( DA_ILL_NAME, InitVar );
} else if( ( InitVar->u.ns.flags & SY_SUB_PARM ) != 0 ) {
ClassNameErr( DA_ILL_NAME, InitVar );
} else if((InitVar->u.ns.flags & SY_SUBSCRIPTED) && _Allocatable( InitVar )) {
IllName( InitVar );
} else {
// Don't set SY_TYPE otherwise we won't be able to detect whether
// the type has been explicitly declared when we call ProcDataExpr().
// SY_TYPE will be set by DSName() when we call ProcDataExpr().
InitVar->u.ns.flags |= SY_USAGE | SY_DATA_INIT;
}
}
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 );
}
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 );
}
void CpEquivalence(void) {
//=======================
// Compile EQUIVALENCE statement.
// EQUIVALENCE (A1,...,An) {,(B1,...,Bm)} . . .
sym_id sym;
int num_equived;
intstar4 *subscripts;
int eq_size;
act_eq_entry *new_eq;
act_eq_entry *eqv_entry;
act_eq_entry *eq_head;
act_eq_entry *eq_set;
bool ill_name;
bool sub_strung;
act_eq_entry equiv;
eq_set = EquivSets;
if( EquivSets != NULL ) {
while( eq_set->next_eq_set != NULL ) {
eq_set = eq_set->next_eq_set;
}
}
for(;;) {
if( RecNOpn() ) {
AdvanceITPtr();
}
ReqOpenParen();
eqv_entry = NULL;
eq_head = NULL;
num_equived = 0;
for(;;) {
AError = FALSE;
if( ReqName( NAME_VAR_OR_ARR ) ) {
num_equived++;
sym = LkSym();
ill_name = TRUE;
if( ( sym->ns.flags & SY_CLASS ) == SY_VARIABLE ) {
if( sym->ns.flags & SY_DATA_INIT ) {
NameErr( ST_DATA_ALREADY, sym );
} else if( sym->ns.flags & SY_SUB_PARM ) {
IllName( sym );
} else if( ( sym->ns.flags & SY_SUBSCRIPTED ) &&
_Allocatable( sym ) ) {
IllName( sym );
} else {
sym->ns.flags |= SY_IN_EQUIV;
ill_name = FALSE;
}
} else {
IllName( sym );
}
AdvanceITPtr();
equiv.name_equived = sym;
equiv.next_eq_entry = NULL;
equiv.next_eq_set = NULL;
equiv.subs_no = 0;
equiv.substr = 0;
equiv.substr1 = 1;
equiv.substr2 = 0;
subscripts = equiv.subscrs;
if( RecOpenParen() ) {
if( !RecNOpn() || !RecNextOpr( OPR_COL ) ) {
sub_strung = FALSE;
for(;;) {
CIntExpr();
*subscripts = ITIntValue( CITNode );
AdvanceITPtr();
if( RecColon() ) {
sub_strung = TRUE;
break;
}
subscripts++;
equiv.subs_no++;
if( equiv.subs_no == MAX_DIM ) break;
if( !RecComma() ) break;
}
if( !sub_strung ) {
ReqCloseParen();
ReqNOpn();
AdvanceITPtr();
if( RecOpenParen() ) {
*subscripts = 1;
if( !RecNOpn() ) {
CIntExpr();
*subscripts = ITIntValue( CITNode );
}
AdvanceITPtr();
sub_strung = ReqColon();
}
}
} else {
sub_strung = TRUE;
}
if( sub_strung ) {
equiv.substr = 1;
if( SubStr2( subscripts ) ) {
equiv.substr = 2;
}
}
}
if( AError ) {
equiv.subs_no = 0;
equiv.substr = 0;
}
if( ( ( SgmtSw & SG_SYMTAB_RESOLVED ) == 0 ) && !ill_name ) {
eq_size = sizeof( eq_entry ) +
equiv.subs_no * sizeof( intstar4 );
if( equiv.substr != 0 ) {
eq_size += 2 * sizeof( intstar4 );
}
new_eq = FMemAlloc( eq_size );
memcpy( new_eq, &equiv, eq_size );
if( eqv_entry == NULL ) {
eq_head = new_eq;
eqv_entry = new_eq;
} else {
eqv_entry->next_eq_entry = new_eq;
eqv_entry = new_eq;
}
if( sym->ns.si.va.vi.ec_ext == NULL ) {
sym->ns.si.va.vi.ec_ext = STComEq();
}
}
} else {
AdvanceITPtr();
}
if( !RecComma() ) break;
}
if( num_equived < 2 ) {
Error( EV_EQUIV_LIST );
}
if( eq_set == NULL ) {
eq_set = eq_head;
EquivSets = eq_head;
} else {
eq_set->next_eq_set = eq_head;
eq_set = eq_head;
}
ReqCloseParen();
ReqNOpn();
AdvanceITPtr();
if( !RecComma() ) break;
}
ReqEOS();
}
