Ejemplo n.º 1
0
static bool UnaryMul( TYPE typ1, TYPE typ2 ) {
//============================================

    if( typ1 > FT_EXTENDED )
        return( FALSE );
    if( !_IsTypeInteger( typ2 ) )
        return( FALSE );
    if( CITNode->link->opn.us != USOPN_CON )
        return( FALSE );
    if( ITIntValue( CITNode->link ) < 0 )
        return( FALSE );
    if( ITIntValue( CITNode->link ) > 8 )
        return( FALSE );
    return( TRUE );
}
Ejemplo n.º 2
0
static  void    ConList( void ) {
//=========================

// Collect constants for data initialization.

    OPR         opr;
    itnode      *last_node;

    opr = FindSlash( &last_node );
    for(;;) {
        if( RecNextOpr( OPR_MUL ) ) {
            ProcDataRepExpr();
            if( ITIntValue( CITNode ) <= 0 ) {
                Error( DA_BAD_RPT_SPEC );
            }
            AddConst( CITNode );
            AdvanceITPtr();
        }
        if( !HexConst() ) {
            GetSConst();
            AddConst( CITNode );
        }
        AdvanceITPtr();
        if( CITNode == last_node )
            break;
        ReqComma();
        if( AError ) {
            break;
        }
    }
    CITNode->opr = opr;
    ReqDiv();
}
Ejemplo n.º 3
0
static  void    ExpOp( TYPE typ1, TYPE typ2, OPTR op ) {
//======================================================

    op = op;
    if( !_IsTypeInteger( typ2 ) ) {
        Convert();
        GenExp( ResultType );
    } else {
        CnvTo( CITNode, ResultType, TypeSize( ResultType ) );
        ExpI( typ1, &CITNode->value, ITIntValue( CITNode->link ) );
    }
}
Ejemplo n.º 4
0
static intstar4 GetIntValue( itnode *node ) {
//===========================================

    if( node->typ == FT_REAL ) {
        return( node->value.single );
    } else if( node->typ == FT_DOUBLE ) {
        return( node->value.dble );
    } else if( node->typ == FT_EXTENDED ) {
        return( node->value.extended );
    } else {
        return( ITIntValue( node ) );
    }
}
Ejemplo n.º 5
0
static  int     SameScripts( itnode *op1, itnode *op2 ) {
//=======================================================

    if( !SimpleScript( op1 ) ) return( 0 );
    if( (op1->opn.us & USOPN_WHAT) == USOPN_NONE ) {
        if( (op2->opn.us & USOPN_WHAT) == USOPN_CON ) {
            return( ITIntValue( op2 ) );
        } else {
            return( 0 );
        }
    }
    if( (op1->opn.us & USOPN_WHAT) != (op2->opn.us & USOPN_WHAT) ) {
        return( 0 );
    }
    if( (op1->opn.us & USOPN_WHAT) == USOPN_NNL ) {
        if( op1->sym_ptr == op2->sym_ptr ) {
            return( 1 );
        }
    } else if( (op1->opn.us & USOPN_WHAT) == USOPN_CON ) {
        return( ITIntValue( op2 ) - ITIntValue( op1 ) + 1 );
    }
    return( 0 );
}
Ejemplo n.º 6
0
void    ExpOp( TYPE typ1, TYPE typ2, OPTR opr ) {
//===============================================

// Generate code to perform exponentiation.

    if( UnaryMul( typ1, typ2 ) ) {
        PushOpn( CITNode );
        EmitOp( FC_UNARY_MUL );
        GenType( CITNode );
        OutU16( ITIntValue( CITNode->link ) );
        SetOpn( CITNode, USOPN_SAFE );
    } else {
        BinOp( typ1, typ2, opr );
    }
}
Ejemplo n.º 7
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 );
}
Ejemplo n.º 8
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();
}