Пример #1
0
void    DetCallList(void) {
//=====================

    itnode      *cit;

    cit = CITNode;
    AdvanceITPtr();
    if( RecNOpn() ) {
        AdvanceITPtr();
    } else {
        SetDefinedStatus();
        AdvanceITPtr();
        while( RecComma() ) {
            if( CheckColon() ) {
                Extension( SS_FUNCTION_VALUE );
                SubStrArgs( cit );
                Detach( cit );
                return;
            }
            if( RecNOpn() ) break;
            SetDefinedStatus();
            AdvanceITPtr();
        }
    }
    if( !RecCloseParen() ) {
        Error( PC_NO_CLOSEPAREN );
    }
    Detach( cit );
}
Пример #2
0
bool    StartImpDo( void ) {
//====================

// This procedure scans the i/o list to recognize an implied do.
// If it is not found false returns, if it is found true returns and:
// -  the implied DO is initialized
// -  a terminal operator is placed over the comma at the
//    end of the i/o list within the implied DO. This is used
//    as a signal to generate closing code for the implied DO.
// -  the nodes containing the do list are released from
//    from the internal text list.
// -  a null operator is placed over the bracket at the

    itnode      *citnode;
    itnode      *lastcomma;
    int         level;

    if( !RecNOpn() )
        return( false );
    if( !RecNextOpr( OPR_LBR ) )
        return( false );
    citnode = CITNode;
    AdvanceITPtr();
    lastcomma = NULL;
    level = 0;
    AdvanceITPtr();
    for(;;) {
        if( RecOpenParen() ) {
            level++;
        } else if( RecCloseParen() ) {
            level--;
        } else if( RecComma() && ( level == 0 ) ) {
            lastcomma = CITNode;
        }
        if( ( level < 0 ) || RecTrmOpr() ) {
            CITNode = citnode;
            return( false );
        }
        AdvanceITPtr();
        if( RecEquSign() && ( level == 0 ) ) {
            break;
        }
    }
    if( ( lastcomma == NULL ) || ( lastcomma->link != CITNode ) ) {
        CITNode = citnode;
        return( false );
    }
    InitImpDo( lastcomma );
    CITNode = citnode;
    AdvanceITPtr();
    if( ( RecNextOpr( OPR_TRM ) && RecNOpn() ) ) {
        Error( IL_EMPTY_IMP_DO );
    }
    return( true );
}
Пример #3
0
void    FormatIdd( void ) {
//=========================

    cs_label    fmt_label;
    grp_entry   *ge;

    if( RecName() && ( NameListFind() != NULL ) ) {
        BIOutNameList( CITNode->sym_ptr );
        ge = CITNode->sym_ptr->u.nl.group_list;
        while( ge != NULL ) {
            ge->sym->u.ns.flags |= SY_REFERENCED;
            ge = ge->link;
        }
        GSetNameList( FC_SET_NML );
        KWRememb( IO_NAMELIST );
    } else if( RecNumber() ) {
        GPassStmtNo( LkUpFormat(), FC_SET_FMT );
    } else if( RecNOpn() && RecNextOpr( OPR_MUL ) ) {
        if( CITNode->link->opn.ds == DSOPN_PHI ) {
            AdvanceITPtr();   // nothing needs to be loaded for default
            KWRememb( IO_LIST_DIR );
        }
    } else if( RecNOpn() && RecNextOpr( OPR_COM ) ) {
        Extension( IL_NO_ASTERISK );
    } else if( RecIntVar() ) {
        CkVarRef();
        StNumbers.var_format = true;
        GFmtVarSet();
    } else {
        ProcIOExpr();           // will allow for array name alone
        if( !AError ) {
            if( RecArrName() ) {
                if( CITNode->typ != FT_CHAR ) {
                    Extension( IL_NON_CHARACTER );
                }
                ChkAssumed();
                GFmtArrSet();
            } else if( CITNode->typ != FT_CHAR ) {
                Error( IL_BAD_FMT_SPEC );
            } else if( ( CITNode->opn.us == USOPN_CON ) ) {
                AddConst( CITNode ); // in case single constant
                fmt_label.g_label = NextLabel();
                FScan( CITNode->sym_ptr->u.lt.length,
                       (char *)&CITNode->sym_ptr->u.lt.value, fmt_label );
                GPassLabel( fmt_label.g_label, RT_SET_FMT );
            } else {
                GFmtExprSet();
            }
        }
    }
}
Пример #4
0
void    Unit(void) {
//===============

    if( RecNOpn() && RecNextOpr( OPR_MUL ) ) {
        if( ( StmtProc != PR_READ ) && ( StmtProc != PR_WRITE ) ) {
            StmtErr( IL_STAR_NOT_ALLOWED );
        }
        AdvanceITPtr();
        ReqNOpn();
    } else {
        ProcIOExpr();
        if( !AError ) {
            if( _IsTypeInteger( CITNode->typ ) && !RecArrName() ) {
                GPassValue( FC_SET_UNIT );
            } else if( CITNode->typ == FT_CHAR ) {
                KWRememb( IO_INTERNAL );
                CkAssignOk();
                if( RecArrName() ) {
                    ChkAssumed();
                    GArrIntlSet();
                } else {
                    GIntlSet();
                }
                if( ( StmtProc != PR_READ ) &&
                    ( StmtProc != PR_WRITE ) &&
                    ( StmtProc != PR_PRINT ) ) {
                    Error( IL_BAD_INTL );
                }
            } else {
                Error( IL_NO_UNIT_ID );
            }
        }
    }
}
Пример #5
0
void CpReturn( void )
{
    if( !(ProgSw & PS_IN_SUBPROGRAM) ) {
        Extension( RE_IN_PROGRAM );
    }
    CkRemBlock();
    if( RecNOpn() && RecNextOpr( OPR_TRM ) ) {
        if( ( ( SubProgId->u.ns.flags & SY_CLASS ) == SY_SUBPROGRAM ) &&
                ( ( SubProgId->u.ns.flags & SY_SUBPROG_TYPE ) == SY_SUBROUTINE ) ) {
            GNullRetIdx();
        }
    } else {
        IntSubExpr();
        if( ( ( SubProgId->u.ns.flags & SY_CLASS ) == SY_SUBPROGRAM ) &&
                ( ( SubProgId->u.ns.flags & SY_SUBPROG_TYPE ) == SY_SUBROUTINE ) ) {
            GRetIdx();
        } else {
            Error( RE_ALT_IN_SUBROUTINE );
        }
    }
    AdvanceITPtr();
    ReqEOS();
    GGotoEpilog();
    Remember.transfer = true;
    Remember.stop_or_return = true;
}
Пример #6
0
void    CpPrint( void ) {
//=================

// Compile PRINT statement.

    itnode      *cit;

    InitIO();
    Form();
    if( !RecEOS() ) {
        ReqComma();
        if( RecNOpn() ) {
            cit = CITNode;
            AdvanceITPtr();
            if( RecEOS() ) {
                CITNode = cit;
                Error( SX_SURP_OPR );
            }
            CITNode = cit;
        }
    }
    IOList();
    ReqEOS();
    FiniIO();
}
Пример #7
0
static  bool            ReadKWList( void ) {
//====================================

    OPR         opr;

    if( Scan4ListOprs() )
        return( true );
    if( SPtr1->opn.ds != DSOPN_PHI )
        return( true ); // have ( ciolist ) name
    opr = SPtr1->link->opr;
    if( opr == OPR_COM )
        return( false ); // have ( fmt ),
    if( opr == OPR_LBR )
        return( true ); // we have ( ciolist ) (a(i) i==1,10)
    if( opr != OPR_TRM )
        return( false );
    if( RecNOpn() )
        return( false );
    if( CITNode->opn.ds == DSOPN_LIT )
        return( false );
    if( CITNode->opn.ds > DSOPN_LIT )
        return( true );
    if( LkSym()->u.ns.u1.s.typ == FT_CHAR )
        return( false );
    return( true );
}
Пример #8
0
void    CpData(void) {
//================

// Compile DATA statement.

    label_id    end_data;
    int         data_sets;
    bool        error;

    // so that we can issue ST_DATA_TOO_EARLY later
    SgmtSw |= SG_SEEN_DATA;
    error = false;
    data_sets = 0;
    CITNode->opr = OPR_COM; // prevent call to FinishImpDo first time
    end_data = GDataProlog();
    for(;;) {
        DoData();
        error |= AError;
        ++data_sets;
        if( RecNOpn() ) {
            AdvanceITPtr();
            if( RecTrmOpr() )
                break;
            ReqComma();
        }
        if( RecTrmOpr() || error ) {
            break;
        }
    }
    if( !error ) {
        DumpDataSets( data_sets, ITHead );
    }
    GDataEpilog( end_data );
    CITNode->opr = OPR_TRM;
}
Пример #9
0
void CpWhile( void )
{
//=================

// Compile a WHILE statement.
//    WHILE( expr )DO <:label> -- block while
//    WHILE( expr )   <:label> -- block while
//    WHILE( expr ) STATEMENT  -- one line while

    CSExtn();
    InitLoop( CS_WHILE );
    CSCond( CSHead->bottom );
    if( RecNOpn() && RecNextOpr( OPR_COL ) ) {
        BlockLabel();
    } else if( RecKeyWord( "DO" ) &&
               ( RecNextOpr( OPR_TRM ) || RecNextOpr( OPR_COL ) ) ) {
        CITNode->opn.ds = DSOPN_PHI;
        BlockLabel();
    } else {
        Recurse();
        GLabel( CSHead->cycle );
        FiniLoop();
        DelCSNode();
    }
}
Пример #10
0
void    CpSave( void ) {
//================

// Compile SAVE statement :    SAVE A1 {,A2 ... }
//
//      where Ai is 1. a common block name preceded and followed by a /
//                  2. an array name
//                  3. a variable name

    sym_id      sym_ptr;

    if( RecNOpn() && RecNextOpr( OPR_TRM ) ) {
        if( ( (SgmtSw & SG_LITTLE_SAVE) != 0 ) || ( (SgmtSw & SG_BIG_SAVE) != 0 ) ) {
            Error( SA_SAVED );
        }
        SgmtSw |= SG_BIG_SAVE;
    } else {
        for( ;; ) {
            if( RecNOpn() && RecNextOpr( OPR_DIV ) ) {
                AdvanceITPtr();
                if( ReqName( NAME_COMMON ) ) {
                    sym_ptr = LkCommon();
                    if( sym_ptr->u.ns.flags == 0 ) {
                        sym_ptr->u.ns.flags |= SY_USAGE | SY_COMMON;
                    }
                    Save( sym_ptr );
                }
                AdvanceITPtr();
                ReqDiv();
                ReqNOpn();
            } else if( ReqName( NAME_VAR_OR_ARR ) ) {
                sym_ptr = LkSym();
                if( ( sym_ptr->u.ns.flags & ~SV_ON_OR_OFF ) != SY_VARIABLE ) {
                    IllName( sym_ptr );
                } else {
                    Save( sym_ptr );
                }
            }
            AdvanceITPtr();
            if( !RecComma() ) {
                break;
            }
        }
        ReqEOS();
    }
}
Пример #11
0
bool    ReqNOpn( void ) {
//=================

    if( RecNOpn() )
        return( true );
    OpndErr( SX_UNEXPECTED_OPN );
    return( false );
}
Пример #12
0
static  void    Detach( itnode *cit ) {
//=====================================

    cit->list = cit->link;
    cit->link = CITNode->link;
    if( !RecNOpn() ) {
        Error( SX_NO_OPR );
    }
    CITNode->link = NULL;
    CITNode = cit;
}
Пример #13
0
void    DetSubList(void) {
//====================

    itnode      *cit;
    int         count;
    byte        no_subs;
    itnode      *save_cit;
    uint        ch_size;

    if( CITNode->opn.us & USOPN_FLD ) {
        no_subs = _DimCount( CITNode->sym_ptr->u.fd.dim_ext->dim_flags );
    } else {
        no_subs = _DimCount( CITNode->sym_ptr->u.ns.si.va.u.dim_ext->dim_flags );
    }
    count = 0;
    cit = CITNode;
    AdvanceITPtr();
    while( RecComma() || RecFBr() ) {
        if( CheckColon() ) {
            if( count == 0 ) {
                save_cit = CITNode;
                CITNode = cit;
                OpndErr( SV_TRIED_SSTR );
                CITNode = save_cit;
            } else if( count != no_subs ) {
                Error( SV_INV_SSCR );
            }
            SubStrArgs( cit );
            cit->opn.us &= ~USOPN_WHAT;
            cit->opn.us |= USOPN_ASS;
            Detach( cit );
            return;
        }
        if( RecNOpn() ) break;
        ++count;
        CkScrStr();
        AdvanceITPtr();
    }
    if( !RecCloseParen() ) {
        Error( PC_NO_CLOSEPAREN );
    }
    if( count != no_subs ) {
        Error( SV_INV_SSCR );
    }
    // we must make sure the array isn't substrung before we can set OPN_SS1
    if( !( cit->opn.us & USOPN_FLD ) && ( cit->sym_ptr->u.ns.u1.s.typ == FT_CHAR ) ) {
        ch_size = cit->sym_ptr->u.ns.xt.size;
        if( ch_size > 0 ) {
            cit->opn.us |= USOPN_SS1;
            cit->value.st.ss_size = ch_size;
        }
    }
    Detach( cit );
}
Пример #14
0
static  void    NumOrLit( FCODE routine ) {
//===============================================

    if( RecNOpn() ) {
        AdvanceITPtr();
    }
    if( RecNOpn() ) {
        GBreak( routine );
    } else if( !RecLiteral() ) {
        if( CITNode->opn.ds == DSOPN_INT ) {
            if( CITNode->opnd_size > 5 ) {
                Extension( ST_LONG_NUM, StmtKeywords[ StmtProc ] );
            }
            BreakOpn( routine );
        } else {
            Error( SX_NUM_OR_LIT );
        }
    } else {
        BreakOpn( routine );
    }
}
Пример #15
0
static  void    DoKWList( void ) {
//==========================

// Call KeywordList() and check for closing parenthesis.

    KeywordList();
    if( ReqCloseParen() ) {
        if( !RecNOpn() ) {
            Error( SX_EOS_EXPECTED );
        }
        AdvanceITPtr();
    }
}
Пример #16
0
void    CpEnd(void) {
//===============

    LFSkip();
    if( RecNOpn() ) {
        ProgSw |= PS_END_OF_SUBPROG;
        AdvanceITPtr();
        Remember.endstmt = true;
        ReqEOS();
    } else {
        BadStmt();
    }
}
Пример #17
0
static  void    JustList( void ) {
//==========================

// The io statement must have a keyword list in brackets.

    InitIO();
    if( RecTrmOpr() && RecNOpn() ) {
        AdvanceITPtr();
    }
    if( ReqOpenParen() ) {
        DoKWList();
    }
    ReqEOS();
    GStartIO();
    FiniIO();
}
Пример #18
0
void    CpWrite( void ) {
//=================

// Compile WRITE statement.

    InitIO();
    if( RecTrmOpr() && RecNOpn() ) {
        AdvanceITPtr();
    }
    if( ReqOpenParen() ) {
        KeywordList();
        ReqCloseParen();
        IOList();
    }
    ReqEOS();
    FiniIO();
}
Пример #19
0
void    IOList( void ) {
//================

// Process the input/output list.

    GStartIO();
    if( CITNode->link != NULL ) {
        if( RecNOpn() && RecNextOpr( OPR_TRM ) ) {
            AdvanceITPtr();                   // WRITE(6,3)
        } else if( Already( IO_NAMELIST ) ) {
            Error( IL_NO_IOLIST );
        }
        for(;;) {
            if( CITNode->link == NULL ) break;
            ProcessList();
        }
    }
    GStopIO();
}
Пример #20
0
static  void    UnitOrList( void ) {
//============================

// The io statement can have a unit id by itself or have a keyword list
// in brackets.

    InitIO();
    if( RecNextOpr( OPR_LBR ) && RecNOpn() ) {
        AdvanceITPtr();
        DoKWList();
    } else {
        Permission( IO_UNIT );           // remembers unit= specified
        Unit();
        AdvanceITPtr();
    }
    ReqEOS();
    GStartIO();
    FiniIO();
}
Пример #21
0
static  void    GetSConst( void ) {
//===========================

// Signed constant converting without downscan-upscan process.

    int         sign;

    if( RecNOpn() ) {
        sign = 1;
        if( RecNextOpr( OPR_MIN ) ) {
            sign = -1;
        } else if( !RecNextOpr( OPR_PLS ) ||
                   ( CITNode->link->opn.ds < DSOPN_INT ) ) {
            ProcDataIExpr();
            return;
        }
        AdvanceITPtr();
        ProcDataIExpr();
        switch( CITNode->typ ) {
        case FT_INTEGER_1:
            CITNode->value.intstar1 *= sign;
            break;
        case FT_INTEGER_2:
            CITNode->value.intstar2 *= sign;
            break;
        case FT_INTEGER:
            CITNode->value.intstar4 *= sign;
            break;
        case FT_REAL:
            CITNode->value.single *= sign;
            break;
        case FT_DOUBLE:
            CITNode->value.dble *= sign;
            break;
        case FT_TRUE_EXTENDED:
            CITNode->value.extended *= sign;
            break;
        }
    } else {
        ProcDataIExpr();
    }
}
Пример #22
0
int     GParms( itnode *sp ) {
//============================

// Process argument list.

    int         num_stmts;

    sp = sp;
    num_stmts = 0;
    for(;;) {
        if( !RecNOpn() ) {  // consider f()
            if( CITNode->opn.us == USOPN_STN ) {
                num_stmts++;
            }
        }
        AdvanceITPtr();
        if( RecCloseParen() || RecColon() ) break;
    }
    return( num_stmts );
}
Пример #23
0
static  void    DumpDataSets( int num, itnode *node ) {
//=====================================================

// Dump the constants for data initialization.

    itnode      *rpt;

    GStopIO();
    CITNode = node;
    GBegDList();
    while( --num >= 0 ) {
        for(;;) {
            AdvanceITPtr();
            if( RecDiv() ) {
                break;
            }
        }
        for(;;) {
            if( RecNextOpr( OPR_MUL ) ) {
                rpt = CITNode;
                AdvanceITPtr();
            } else {
                rpt = NULL;
            }
            if( RecNOpn() ) { // jump over optional sign.
                AdvanceITPtr();
            }
            GDataItem( rpt );
            AdvanceITPtr();
            if( RecDiv() ) {
                break;
            }
        }
        GEndDSet();
    }
    GEndDList();
}
Пример #24
0
void    ListItem( void ) {
//==================

// Process one list item.

    sym_id      sd;

    if( RecNOpn() ) {
        if( !CpError ) {
            Error( SX_SURP_OPR );
        }
    } else if( RecArrName() ) {
        CITNode->sym_ptr->ns.u1.s.xflags |= SY_DEFINED;
        ChkAssumed();
        if( CITNode->typ == FT_STRUCTURE ) {
            ChkStructIO( CITNode->sym_ptr->ns.xt.sym_record );
            GIOStructArray();
        } else {
            GIOArray();
        }
    } else if( CITNode->typ == FT_STRUCTURE ) {
        CITNode->sym_ptr->ns.u1.s.xflags |= SY_DEFINED;
        if( CITNode->opn.us & USOPN_FLD ) {
            sd = CITNode->value.st.field_id->fd.xt.sym_record;
        } else {
            sd = CITNode->sym_ptr->ns.xt.sym_record;
        }
        ChkStructIO( sd );
        GIOStruct( sd );
    } else {
        if( StmtProc == PR_READ ) {
            CkAssignOk();
        }
        GIOItem();
    }
    AdvanceITPtr();
}
Пример #25
0
static  bool    SubStr2( intstar4 *subscripts ) {
//===============================================

// Get the second component of a substring expression.

    bool        got_colon;
    bool        hi;

    subscripts++;
    got_colon = RecColon();
    hi = FALSE;
    if( !RecNOpn() ) {
        CIntExpr();
        *subscripts = ITIntValue( CITNode );
        hi = TRUE;
    }
    if( got_colon ) {
        AdvanceITPtr();
    }
    ReqCloseParen();
    ReqNOpn();
    AdvanceITPtr();
    return( hi );
}
Пример #26
0
static  void    Generate( void ) {
//================================

// Generate code.

    TYPE        typ1;
    TYPE        typ2;
    OPTR        op;
    OPR         opr;
    itnode      *next;
    unsigned_16 mask;
    uint        res_size;

    next = CITNode->link;
    if( next->opn.ds == DSOPN_PHI ) {
        BadSequence();
    } else {
        typ1 = CITNode->typ;
        typ2 = next->typ;
        opr = next->opr;
        if( RecNOpn() ) {
            typ1 = FT_NO_TYPE;
            CITNode->size = next->size;
            if( (opr != OPR_PLS) && (opr != OPR_MIN) && (opr != OPR_NOT) ) {
                BadSequence();
                return;
            }
        }
        op = OprNum[ opr ];
        if( typ1 == FT_NO_TYPE ) {
            mask = LegalOprsU[ typ2 - FT_FIRST ];
        } else {
            mask = LegalOprsB[ ( typ2 - FT_FIRST ) * LEGALOPR_TAB_COLS + typ1 - FT_FIRST ];
        }
        if( (( mask >> ( op - OPTR_FIRST ) ) & 1) == 0 ) {
            // illegal combination
            MoveDown();
            if( typ1 == FT_NO_TYPE ) {
                TypeErr( MD_UNARY_OP, typ2 );
            } else if( typ1 == typ2 ) {
                TypeErr( MD_ILL_OPR, typ1 );
            } else {
                TypeTypeErr( MD_MIXED, typ1, typ2 );
            }
            BackTrack();
        } else if( DoGenerate( typ1, typ2, &res_size ) ) {
            if( ( opr >= OPR_FIRST_RELOP ) && ( opr <= OPR_LAST_RELOP ) &&
                ( (ResultType == FT_COMPLEX) || (ResultType == FT_DCOMPLEX) ||
                (ResultType == FT_XCOMPLEX) ) &&
                ( opr != OPR_EQ ) && ( opr != OPR_NE ) ) {
                // can only compare complex with .EQ. and .NE.
                Error( MD_RELOP_OPND_COMPLEX );
            } else {
                if( ( next->opn.us == USOPN_CON ) &&
                    ( ( CITNode->opn.us == USOPN_CON ) || ( typ1 == FT_NO_TYPE ) ) ) {
                    // we can do some constant folding
                    ConstTable[ op ]( typ1, typ2, op );
                } else {
                    // we have to generate code
                    if( CITNode->opn.us == USOPN_CON ) {
                        AddConst( CITNode );
                    } else if( next->opn.us == USOPN_CON ) {
                        AddConst( next );
                    }
                    GenOprTable[ op ]( typ1, typ2, op );
                }
            }
            switch( opr ) {
            case OPR_EQV:
            case OPR_NEQV:
            case OPR_OR:
            case OPR_AND:
            case OPR_NOT:
                if( _IsTypeInteger( typ1 ) ) {
                    Extension( MD_LOGOPR_INTOPN );
                }
                break;
            case OPR_EQ:        // relational operators
            case OPR_NE:
            case OPR_LT:
            case OPR_GE:
            case OPR_LE:
            case OPR_GT:
                ResultType = FT_LOGICAL;
                res_size = TypeSize( ResultType );
                break;
            case OPR_FLD:
            case OPR_DPT:
                // set result size to size of field
                res_size = next->size;
                FixFldNode();
                break;
            }
            CITNode->size = res_size;
            CITNode->typ = ResultType;
            FixList();
        }
    }
Пример #27
0
void    SFPrologue( void ) {
//====================

// Generate code for statement function prologue.

    sym_id      sym;
    itnode      *func_node;
    itnode      *arg_list;
    sf_parm     **parm;

    StmtSw |= SS_SF_REFERENCED;
    CkTypeDeclared();
    SFSymId = CITNode->sym_ptr;
    if( ( SFSymId->ns.typ == FT_CHAR ) && ( SFSymId->ns.xt.size == 0 ) ) {
        Error( SF_ILL_CHAR_LEN );
    } else if( SFSymId->ns.typ == FT_STRUCTURE ) {
        Error( SF_ILL_TYPE );
    }
    GStartSF();
    SFSymId->ns.flags = SY_USAGE | SY_TYPE | SY_SUBPROGRAM | SY_STMT_FUNC;
    CITNode->flags = SFSymId->ns.flags;
    func_node = CITNode;
    AdvanceITPtr();
    ReqOpenParen();
    SFSymId->ns.si.sf.header = FMemAlloc( sizeof( sf_header ) );
    SFSymId->ns.si.sf.header->ref_count = 1;
    parm = &SFSymId->ns.si.sf.header->parm_list;
    *parm = NULL;
    if( RecNOpn() ) {
        AdvanceITPtr();
    } else {
        for(;;) {
            if( ReqName( NAME_SF_DUMMY ) ) {
                sym = LkSym();
                sym->ns.xflags |= SY_DEFINED;
                CkTypeDeclared();
                if( ( ( sym->ns.flags & SY_CLASS ) == SY_VARIABLE ) &&
                    ( ( sym->ns.flags & SY_SUBSCRIPTED ) == 0 ) &&
                    ( ( sym->ns.typ != FT_CHAR ) ||
                      ( sym->ns.xt.size != 0 ) ) &&
                    ( sym->ns.typ != FT_STRUCTURE ) ) {
                    if( sym->ns.flags & SY_SPECIAL_PARM ) {
                        Error( SF_DUPLICATE_DUMMY_PARM );
                    } else {
                        *parm = FMemAlloc( sizeof( sf_parm ) );
                        (*parm)->link = NULL;
                        (*parm)->actual = sym;
                        (*parm)->shadow = STShadow( sym );
                        parm = &((*parm)->link);
                    }
                } else {
                    Error( SF_ILL_DUMMY_PARM );
                }
            }
            AdvanceITPtr();
            if( !RecComma() ) break;
        }
    }
    ReqCloseParen();
    ReqNOpn();
    arg_list = func_node->link;
    func_node->link = CITNode->link;
    CITNode->link = NULL;
    CITNode = func_node;
    FreeITNodes( arg_list );
}
Пример #28
0
void    CpEquivalence(void) {
//=======================

// Compile EQUIVALENCE statement.

//     EQUIVALENCE (A1,...,An) {,(B1,...,Bm)} . . .

    sym_id              sym;
    int                 num_equived;
    intstar4            *subscripts;
    int                 eq_size;
    act_eq_entry        *new_eq;
    act_eq_entry        *eqv_entry;
    act_eq_entry        *eq_head;
    act_eq_entry        *eq_set;
    bool                ill_name;
    bool                sub_strung;
    act_eq_entry        equiv;

    eq_set = EquivSets;
    if( EquivSets != NULL ) {
        while( eq_set->next_eq_set != NULL ) {
            eq_set = eq_set->next_eq_set;
        }
    }
    for(;;) {
        if( RecNOpn() ) {
            AdvanceITPtr();
        }
        ReqOpenParen();
        eqv_entry = NULL;
        eq_head = NULL;
        num_equived = 0;
        for(;;) {
            AError = FALSE;
            if( ReqName( NAME_VAR_OR_ARR ) ) {
                num_equived++;
                sym = LkSym();
                ill_name = TRUE;
                if( ( sym->ns.flags & SY_CLASS ) == SY_VARIABLE ) {
                    if( sym->ns.flags & SY_DATA_INIT ) {
                        NameErr( ST_DATA_ALREADY, sym );
                    } else if( sym->ns.flags & SY_SUB_PARM ) {
                        IllName( sym );
                    } else if( ( sym->ns.flags & SY_SUBSCRIPTED ) &&
                                _Allocatable( sym ) ) {
                        IllName( sym );
                    } else {
                        sym->ns.flags |= SY_IN_EQUIV;
                        ill_name = FALSE;
                    }
                } else {
                    IllName( sym );
                }
                AdvanceITPtr();
                equiv.name_equived = sym;
                equiv.next_eq_entry = NULL;
                equiv.next_eq_set = NULL;
                equiv.subs_no = 0;
                equiv.substr = 0;
                equiv.substr1 = 1;
                equiv.substr2 = 0;
                subscripts = equiv.subscrs;
                if( RecOpenParen() ) {
                    if( !RecNOpn() || !RecNextOpr( OPR_COL ) ) {
                        sub_strung = FALSE;
                        for(;;) {
                            CIntExpr();
                            *subscripts = ITIntValue( CITNode );
                            AdvanceITPtr();
                            if( RecColon() ) {
                                sub_strung = TRUE;
                                break;
                            }
                            subscripts++;
                            equiv.subs_no++;
                            if( equiv.subs_no == MAX_DIM ) break;
                            if( !RecComma() ) break;
                        }
                        if( !sub_strung ) {
                            ReqCloseParen();
                            ReqNOpn();
                            AdvanceITPtr();
                            if( RecOpenParen() ) {
                                *subscripts = 1;
                                if( !RecNOpn() ) {
                                    CIntExpr();
                                    *subscripts = ITIntValue( CITNode );
                                }
                                AdvanceITPtr();
                                sub_strung = ReqColon();
                            }
                        }
                    } else {
                        sub_strung = TRUE;
                    }
                    if( sub_strung ) {
                        equiv.substr = 1;
                        if( SubStr2( subscripts ) ) {
                            equiv.substr = 2;
                        }
                    }
                }
                if( AError ) {
                    equiv.subs_no = 0;
                    equiv.substr = 0;
                }
                if( ( ( SgmtSw & SG_SYMTAB_RESOLVED ) == 0 ) && !ill_name ) {
                    eq_size = sizeof( eq_entry ) +
                              equiv.subs_no * sizeof( intstar4 );
                    if( equiv.substr != 0 ) {
                        eq_size += 2 * sizeof( intstar4 );
                    }
                    new_eq = FMemAlloc( eq_size );
                    memcpy( new_eq, &equiv, eq_size );
                    if( eqv_entry == NULL ) {
                        eq_head = new_eq;
                        eqv_entry = new_eq;
                    } else {
                        eqv_entry->next_eq_entry = new_eq;
                        eqv_entry = new_eq;
                    }
                    if( sym->ns.si.va.vi.ec_ext == NULL ) {
                        sym->ns.si.va.vi.ec_ext = STComEq();
                    }
                }
            } else {
                AdvanceITPtr();
            }
            if( !RecComma() ) break;
        }
        if( num_equived < 2 ) {
            Error( EV_EQUIV_LIST );
        }
        if( eq_set == NULL ) {
            eq_set = eq_head;
            EquivSets = eq_head;
        } else {
            eq_set->next_eq_set = eq_head;
            eq_set = eq_head;
        }
        ReqCloseParen();
        ReqNOpn();
        AdvanceITPtr();
        if( !RecComma() ) break;
    }
    ReqEOS();
}