static void CkNameNoList( void ) {
//==============================
// Check that array/subprogram with no list is alright.
if( ( ASType & AST_IO ) && RecTrmOpr() && RecNextOpr( OPR_TRM ) ) {
if( ( CITNode->opn.us & USOPN_WHAT ) != USOPN_ARR ) {
ClassErr( SV_NO_LIST, CITNode->sym_ptr );
}
return;
}
if( ( !RecNextOpr( OPR_COM ) && !RecNextOpr( OPR_RBR ) ) ||
( !RecComma() && !RecFBr() ) ) {
ClassErr( SV_NO_LIST, CITNode->sym_ptr );
}
}
static void CkScrStr( void ) {
//==========================
USOPN opn;
ChkType( FT_INTEGER );
opn = CITNode->opn.us;
if( (opn & USOPN_WHAT) != USOPN_ARR ) return;
ClassErr( SV_NO_LIST, CITNode->sym_ptr );
}
sym_id AddSP2GList( sym_id ste_ptr ) {
//=========================================
// Add a subprogram to the global list.
sym_id gbl;
unsigned_16 flags;
unsigned_16 subprog;
unsigned_16 gsubprog;
flags = ste_ptr->ns.flags;
subprog = flags & SY_SUBPROG_TYPE;
gbl = SearchGList( ste_ptr );
if( gbl == NULL ) {
gbl = LnkNewGlobal( ste_ptr );
gbl->ns.flags &= ~SY_REFERENCED;
} else if( ( gbl->ns.flags & SY_CLASS ) != SY_SUBPROGRAM ) {
PrevDef( gbl );
return( gbl );
} else {
gsubprog = gbl->ns.flags & SY_SUBPROG_TYPE;
if( gsubprog == SY_FN_OR_SUB ) {
// We don't know what global symbol is - it could be a
// function, subroutine or block data subprogram.
// If we know what the local symbol is then the global symbol
// becomes what the local symbol is.
gbl->ns.flags &= ~SY_FN_OR_SUB;
gbl->ns.flags |= subprog;
} else if( (gsubprog != subprog) && (subprog != SY_FN_OR_SUB) ) {
PrevDef( gbl );
return( gbl );
}
}
if( ( flags & SY_PS_ENTRY ) || ( subprog == SY_BLOCK_DATA ) ) {
if( gbl->ns.flags & SY_ADDR_ASSIGNED ) {
if( ( ( subprog != SY_PROGRAM ) && ( subprog != SY_BLOCK_DATA ) ) ||
( ( flags & SY_UNNAMED ) == 0 ) ) {
PrevDef( gbl );
} else {
ClassErr( SR_TWO_UNNAMED, gbl );
}
} else {
gbl->ns.flags |= SY_ADDR_ASSIGNED;
}
}
return( gbl );
}
sym_id CkAssignOk( void ) {
//============================
// Check if operand is allowed to be assigned a value.
sym_id sym;
switch( CITNode->opn.us & USOPN_WHAT ) {
case USOPN_NNL:
case USOPN_ASS:
case USOPN_NWL:
case USOPN_ARR:
if( ClassIs( SY_VARIABLE ) ) {
if( BitOn( SY_DO_PARM ) ) {
Error( DO_PARM_REDEFINED );
return( NULL );
}
sym = CITNode->sym_ptr;
// Consider: READ *, CH(I:J)
// GFiniSS() sets the symbol table entry in the I.T. node
// to the temporary SCB so we need to get the actual symbol
// we are substringing elsewhere
if( CITNode->opn.us & USOPN_ASY ) {
sym = CITNode->value.st.ss_id;
}
sym->u.ns.u1.s.xflags |= SY_DEFINED;
return( sym );
} else {
ClassErr( EQ_CANNOT_ASSIGN, CITNode->sym_ptr );
return( NULL );
}
break;
default:
Error( EQ_BAD_TARGET );
return( NULL );
}
}
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;
}
}
}
}