void SetDefinedStatus(void) {
//==========================
switch( CITNode->opn.us & USOPN_WHAT ) {
case USOPN_NNL:
case USOPN_ASS:
case USOPN_NWL:
case USOPN_ARR:
if( ClassIs( SY_VARIABLE ) ) {
CITNode->sym_ptr->u.ns.u1.s.xflags |= SY_DEFINED;
}
}
}
void CpCall(void) {
//================
itnode *next;
unsigned_16 sp_type;
next = CITNode->link;
if( next->opr == OPR_TRM ) {
ASType = AST_CNA; // call with no parameter list
} else if( ( next->opr == OPR_LBR ) &&
( next->opn.ds == DSOPN_PHI ) &&
( next->link->opr == OPR_RBR ) &&
( next->link->opn.ds == DSOPN_PHI ) &&
( next->link->link->opr == OPR_TRM ) ) {
next->opr = OPR_TRM; // make CALL SAM() same as CALL SAM
ASType = AST_CNA; // call with no parameter list
} else {
ReqNextOpr( OPR_LBR, SX_SURP_OPR );
if( ( SPtr1 != NULL ) && ( SPtr1->link->opr != OPR_TRM ) ) {
Error( SX_JUNK_AFTER_RBR ); // ignore anything after
SPtr1->link->opr = OPR_TRM; // closing parenthesis
}
ASType = AST_OFF;
}
if( ReqName( NAME_SUBROUTINE ) ) {
LkSym();
if( ClassIs( SY_SUBPROGRAM ) ) {
sp_type = CITNode->flags & SY_SUBPROG_TYPE;
if( sp_type == SY_SUBROUTINE ) {
ASType |= AST_ALT;
Arith();
} else if( sp_type == SY_FUNCTION ) {
Extension( SR_FUNC_AS_SUB );
Arith();
} else if( sp_type == 0 ) {
ArithNewSubr();
} else {
Error( SR_NO_SUBRTN_NAME );
}
} else {
if( CITNode->flags & SY_USAGE ) {
Error( SR_NO_SUBRTN_NAME );
} else if( CITNode->flags & SY_SAVED ) {
Error( SA_SAVED );
} else {
ArithNewSubr();
}
}
}
}
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;
}
}
}
}
