Exemple #1
0
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;
        }
    }
}
Exemple #2
0
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();
            }
        }
    }
}
Exemple #3
0
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 );
    }
}
Exemple #4
0
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;
            }
        }
    }
}