Exemplo n.º 1
0
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 );
    }
}
Exemplo n.º 2
0
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 );
}
Exemplo n.º 3
0
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 );
}
Exemplo n.º 4
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 );
    }
}
Exemplo n.º 5
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;
            }
        }
    }
}