void BIOutNameList( sym_id ste_ptr ) {
//=======================================
char name[33];
grp_entry *ge;
dw_handle var;
if( _GenerateBrInfo() ) {
if( !( ste_ptr->u.nl.dbh ) ) {
strncpy( name, ste_ptr->u.nl.name, ste_ptr->u.nl.name_len );
name[ste_ptr->u.nl.name_len] = 0;
BIOutSrcLine();
ge = ste_ptr->u.nl.group_list;
while( ge != NULL ) {
var = BIGetHandle( ge->sym );
if( !var ) {
BIOutSymbol( ge->sym );
}
ge = ge->link;
}
ste_ptr->u.nl.dbh = DWNameListBegin( cBIId, name );
ge = ste_ptr->u.nl.group_list;
while( ge != NULL ) {
DWNameListItem( cBIId, BIGetHandle( ge->sym ) );
ge = ge->link;
}
DWEndNameList( cBIId );
}
BIRefSymbol( ste_ptr->u.nl.dbh );
}
}
void CpExecute( void )
{
sym_id rb;
if( StNumbers.in_remote ) {
CkRemBlkRec();
}
if( BlockName( 0 ) ) {
rb = CITNode->sym_ptr;
if( ( rb->ns.flags & ( SY_RB_DEFINED | SY_REFERENCED ) ) == 0 ) {
rb->ns.si.rb.ref_count = 0;
}
rb->ns.si.rb.ref_count++;
BIOutSymbol( rb ); // reference and or declare the sucker
rb->ns.flags |= SY_REFERENCED;
GExecute();
}
AdvanceITPtr();
ReqEOS();
}
void InitDo( signed_32 term )
{
// Initialize a DO or implied DO.
// Process "do i=e1,e2,e3" where e1, e2 and e3 are numeric expressions.
//
do_entry *do_pointer;
sym_id do_var;
if( ( StmtSw & SS_DATA_INIT ) == 0 ) {
CSHead->branch = NextLabel();
CSHead->bottom = NextLabel();
CSHead->cycle = NextLabel();
}
do_pointer = FMemAlloc( sizeof( do_entry ) );
CSHead->cs_info.do_parms = do_pointer;
do_pointer->do_term = term;
do_pointer->do_parm = NULL;
if( ReqDoVar() ) {
CkTypeDeclared();
do_var = CITNode->sym_ptr;
BIOutSymbol( do_var );
do_var->u.ns.flags |= SY_REFERENCED;
do_var->u.ns.u1.s.xflags |= SY_DEFINED;
if( do_var->u.ns.flags & SY_DO_PARM ) {
Error( DO_PARM_REDEFINED );
}
do_pointer->do_parm = do_var; // remember id of "i"
ReqNextOpr( OPR_EQU, EQ_NO_EQUALS );
if( StmtSw & SS_DATA_INIT ) {
if( !_IsTypeInteger( do_var->u.ns.u1.s.typ ) ) {
NameErr( DA_BAD_DO_VAR, do_var );
}
do_var = STShadow( do_var );
CITNode->flags = do_var->u.ns.flags;
}
CITNode->sym_ptr = do_var;
GDoInit( do_var->u.ns.u1.s.typ );
do_var->u.ns.flags |= SY_DO_PARM;
}
}
void BIOutSymbol( sym_id ste_ptr ) {
//=====================================
// define/declare/reference a symbol
dw_handle temp;
if( !_GenerateBrInfo() ) return;
if ( !( currState & BI_STATE_IN_SCOPE ) ) {
BISetHandle( ste_ptr, 0 );
return;
}
BIOutSrcLine();
if ( !( ste_ptr->u.ns.flags & SY_REFERENCED ) ) {
if ( ( ste_ptr->u.ns.flags & SY_CLASS ) == SY_SUBPROGRAM ) {
if((ste_ptr->u.ns.flags & SY_SUBPROG_TYPE)==SY_STMT_FUNC ) {
if( ( ASType & AST_ASF ) &&
!( currState & BI_STATE_IN_STMT_FUNC ) ) { //if defining s.f.
BIOutSF( ste_ptr );
} else {
BIRefSymbol( BIGetHandle( ste_ptr ) );
}
} else if((ste_ptr->u.ns.flags & SY_SUBPROG_TYPE)==SY_REMOTE_BLOCK){
BIOutDeclareSP( ste_ptr, 0 );
} else {
if ( !( ste_ptr->u.ns.flags & SY_PS_ENTRY ) ) {
BIOutDeclareSP( ste_ptr, DW_FLAG_GLOBAL );
} else {
BIRefSymbol( BIGetHandle( ste_ptr ) );
}
}
} else if ( ( ste_ptr->u.ns.flags & SY_CLASS ) == SY_VARIABLE ) {
if ( ste_ptr->u.ns.flags & SY_SUB_PARM ) {
if ( currState & BI_STATE_RESOLVED ) {
BIRefSymbol( BIGetHandle( ste_ptr ) );
} else {
BIAdd2List( &fixSubParms, ste_ptr, CurrFile->rec );
}
} else if ( !( ste_ptr->u.ns.flags & SY_SPECIAL_PARM ) ) {
if ( !( ste_ptr->u.ns.flags & SY_IN_COMMON ) ||
( currState & BI_STATE_IN_COMMON_BLOCK ) ) {
BIOutVar( ste_ptr );
} else if ( !( ste_ptr->u.ns.flags &
( SY_DATA_INIT | SY_IN_DIMEXPR ) ) ||
!( ste_ptr->u.ns.flags & SY_IN_COMMON ) ) {
BIRefSymbol( BIGetHandle( ste_ptr ) );
}
} else if ( currState & BI_STATE_IN_STMT_FUNC ) {
BIRefSymbol( BIGetHandle( ste_ptr->u.ns.si.ms.sym ) );
}
} else if ( ( ste_ptr->u.ns.flags & SY_CLASS ) == SY_PARAMETER ) {
BIOutConst( ste_ptr );
}
} else {
// Do we need to use the magic symbol when referencing?
if ( ( currState & BI_STATE_IN_STMT_FUNC ) &&
( ste_ptr->u.ns.flags & SY_SPECIAL_PARM ) ) {
BIRefSymbol( BIGetHandle( ste_ptr->u.ns.si.ms.sym ) );
} else if ( ( ste_ptr->u.ns.flags & SY_SUB_PARM ) &&
( !( currState & BI_STATE_RESOLVED ) ) ) {
BIAdd2List( &fixSubParms, ste_ptr, CurrFile->rec );
} else {
temp = BIGetHandle( ste_ptr );
if ( temp ) {
BIRefSymbol( temp );
} else {
// Consider: data ( x(i), i=1,3 ) ...
// do 666 i = 1, 3
// ....
// 666 continue
// The variable has yet to be declared since it
// was first referenced before the sub prog definition
// so we must turn of the reference bit,
// Dump thhe symbol
// and set the bit on again
ste_ptr->u.ns.flags &= ~SY_REFERENCED;
BIOutSymbol( ste_ptr );
ste_ptr->u.ns.flags |= SY_REFERENCED;
}
}
}
}
void DSName( void ) {
//================
// Downscan a name.
sym_id sym_ptr;
CITNode->opn.us = USOPN_NNL;
if( RecNextOpr( OPR_LBR ) ) {
CITNode->link->opr = OPR_FBR;
CITNode->opn.us = USOPN_NWL;
}
if( ( FieldNode != NULL ) &&
( ( CITNode->opr == OPR_FLD ) || ( CITNode->opr == OPR_DPT ) ) ) {
if( FieldNode->opn.us & USOPN_FLD ) {
LkField( FieldNode->sym_ptr->fd.xt.sym_record );
} else {
LkField( FieldNode->sym_ptr->ns.xt.sym_record );
}
CITNode->opn.us |= USOPN_FLD;
if( CITNode->sym_ptr != NULL ) { // make sure field name exists
if( CITNode->sym_ptr->fd.dim_ext != NULL ) { // field is an array
if( ( CITNode->opn.us & USOPN_WHAT ) != USOPN_NWL ) {
CITNode->opn.us &= ~USOPN_WHAT;
CITNode->opn.us |= USOPN_ARR;
CkFieldNoList();
}
} else if( ( CITNode->opn.us & USOPN_WHAT ) == USOPN_NWL ) {
// field better be character and substrung
if( ( CITNode->sym_ptr->fd.typ != FT_CHAR ) || !SubStrung() ) {
AdvError( PC_SURP_PAREN );
}
}
// setup FieldNode for the next field lookup
if( CITNode->sym_ptr->fd.typ == FT_STRUCTURE ) {
// chain fields for CkFieldNoList()
CITNode->value.sc.struct_chain = FieldNode;
FieldNode = CITNode; // must come after LkField()
} else {
// this field is not structured so go back to the previous
// FieldNode
// consider: STRUCTURE /S1/
// INTEGER J
// END STRUCTURE
// STRUCTURE /S2/
// RECORD /S1/ A(10)
// END STRUCTURE
// RECORD /S2/ X
// RECORD /S1/ I
// X%A(I%J)%K
// when we are done with I%J, set FieldNode back to "A" so we
// can compute offset of "K" (see ChkStructName())
//
// we must go back as many as necessary, i.e. a(b.c.d.e).f
while( (FieldNode->opr==OPR_DPT) || (FieldNode->opr==OPR_FLD) ){
FieldNode = FieldNode->value.sc.struct_chain;
}
FieldNode = FieldNode->value.sc.struct_chain;
}
}
return;
}
if( ASType & AST_ISIZEOF ) {
// Case 1: Case 2:
// STRUCTURE /XXX/ STRUCTURE /XXX/
// INTEGER I INTEGER I
// END STRUCTURE END STRUCTURE
// INTEGER XXX PRINT *, ISIZEOF( XXX )
// PRINT *, ISIZEOF( XXX )
// Case 1:
// We want to issue an "unreferenced" error for XXX so don't set
// SY_REFERENCED bit in symbol table.
// Case 2:
// We don't want to issue "undeclared type" error for XXX if XXX
// did not appear in a type declaration statement.
sym_id sd;
ASType &= ~AST_ISIZEOF;
sd = FindStruct( CITNode->opnd, CITNode->opnd_size );
if( sd != NULL ) {
CITNode->opn.us = USOPN_CON;
CITNode->typ = FT_STRUCTURE;
CITNode->value.intstar4 = sd->sd.size;
return;
}
}
sym_ptr = LkSym();
if( ( ASType & AST_DEXP ) && ( sym_ptr != InitVar ) &&
( ( sym_ptr->ns.flags & SY_CLASS ) != SY_PARAMETER ) &&
( ( ( sym_ptr->ns.flags & SY_CLASS ) != SY_VARIABLE ) ||
( ( sym_ptr->ns.flags & SY_SPECIAL_PARM ) == 0 ) ) ) {
NameErr( DA_BAD_VAR_IN_EXPR, sym_ptr );
}
if( ClassIs( SY_VARIABLE ) ) {
ChkStructName();
if( Subscripted() ) { // if dimensioned
if( ASType & AST_DIM ) {
ClassErr( DM_SYM_PARM, sym_ptr );
} else if( !RecNWL() ) {
CITNode->opn.us = USOPN_ARR; // array without subscript list
CkNameNoList();
}
SetTypeUsage( SY_TYPE | SY_USAGE );
} else if( RecNWL() ) { // if name with list, not dimensioned
if( ASType & AST_DIM ) {
IllName( sym_ptr );
} else if( (CITNode->typ == FT_CHAR) && SubStrung() ) {
SetTypeUsage( SY_TYPE | SY_USAGE );
} else {
ScanningFunction();
}
} else {
if( ASType & AST_DIM ) {
CITNode->flags |= SY_IN_DIMEXPR;
SetTypeUsage( SY_USAGE );
} else {
SetTypeUsage( SY_TYPE | SY_USAGE );
}
}
} else if( ClassIs( SY_SUBPROGRAM ) ) {
ChkStructName();
if( ASType & AST_DIM ) {
ClassErr( DM_SYM_PARM, sym_ptr );
} else {
SubProg();
}
} else { // if( ClassIs( SY_PARAMETER ) ) {
if( RecNWL() ) {
IllName( sym_ptr );
} else {
CITNode->opn.us = USOPN_CON;
CITNode->sym_ptr = sym_ptr->ns.si.pc.value;
if( CITNode->typ == FT_CHAR ) {
if( StmtSw & SY_DATA_INIT ) {
CITNode->sym_ptr->lt.flags |= LT_DATA_STMT;
} else {
CITNode->sym_ptr->lt.flags |= LT_EXEC_STMT;
}
CITNode->value.cstring.strptr = (char *)&CITNode->sym_ptr->lt.value;
CITNode->value.cstring.len = CITNode->sym_ptr->lt.length;
} else {
memcpy( &CITNode->value, &CITNode->sym_ptr->cn.value,
CITNode->size );
}
}
}
BIOutSymbol( sym_ptr );
if( ( sym_ptr->ns.flags & SY_REFERENCED ) == 0 ) {
if( ASType & AST_ASF ) {
if( sym_ptr != SFSymId ) {
sym_ptr->ns.flags |= SY_REFERENCED;
}
} else if( ( ASType & AST_DEXP ) == 0 ) {
if( SgmtSw & SG_SYMTAB_RESOLVED ) {
sym_ptr->ns.flags |= SY_REFERENCED;
} else if( ASType & ( AST_DIM | AST_CEX | AST_DIEXP ) ) {
sym_ptr->ns.flags |= SY_REFERENCED;
}
}
}
}