Exemple #1
0
static  void    ChkExtendFmt( void ) {
//==============================

    if( Options & OPT_EXTEND_FORMAT ) {
        OutU16( 1 );
    } else {
        OutU16( 0 );
    }
}
Exemple #2
0
void    GPassLabel( label_id label, RTCODE routine ) {
//==================================================

// Pass the label identifying encoded format string.
// Called when using
//        PRINT <constant character expression>, ...

    EmitOp( FC_PASS_LABEL );
    OutU16( routine );
    OutU16( label );
}
Exemple #3
0
void    AsgnChar( void ) {
//========================

// Perform character assignment.

    itnode      *save_cit;
    uint        num_args;
    uint        i;
    uint        j;

    save_cit = CITNode;
    AdvanceITPtr();
    num_args = AsgnCat();
    i = SrcChar( CITNode );
    j = TargChar( save_cit );
    if( ( num_args == 1 ) && ( i > 0 ) && ( j > 0 ) ) {
        if( OptimalChSize( i ) && OptimalChSize( j ) && ( i == j ) ) {
            PushOpn( save_cit );
            EmitOp( FC_CHAR_1_MOVE );
            DumpType( MapTypes( FT_INTEGER, i ), i );
            GenChar1Op( CITNode );
            if( ( CITNode->opn.us & USOPN_WHAT ) == USOPN_CON ) {
                CITNode->sym_ptr->u.lt.flags &= ~LT_SCB_TMP_REFERENCE;
            }
            CITNode = save_cit;
        } else {
#if ( _CPU == 386 || _CPU == 8086 )
            if( j < i ) {
                i = j;
            }
            CITNode = save_cit;
            PushOpn( CITNode );
            EmitOp( FC_CHAR_N_MOVE );
            OutInt( i );
            OutInt( j );
#else
            CatArgs( num_args );
            CITNode = save_cit;
            PushOpn( CITNode );
            EmitOp( FC_CAT );
            OutU16( (uint_16)num_args );
#endif
        }
    } else {
        CatArgs( num_args );
        CITNode = save_cit;
        PushOpn( CITNode );
        EmitOp( FC_CAT );
        OutU16( (uint_16)num_args );
    }
}
Exemple #4
0
void    GBegCall( itnode *itptr ) {
//=================================

// Initialize for subprogram invocation.

    sym_id      sp;
    obj_ptr     curr_obj;
    int         num_args;

    sp = itptr->sym_ptr;
#if _CPU == 386
    {
        aux_info    *aux;
        aux = AuxLookupName( sp->u.ns.name, sp->u.ns.u2.name_len );
        if( aux != NULL ) {
            if( aux->cclass & FAR16_CALL ) {
                if( (SubProgId->u.ns.flags & SY_SUBPROG_TYPE) == SY_PROGRAM ) {
                    ProgramInfo.cclass |= THUNK_PROLOG;
                } else {
                    aux = AuxLookupAdd( SubProgId->u.ns.name, SubProgId->u.ns.u2.name_len );
                    aux->cclass |= THUNK_PROLOG;
                }
            }
        }
    }
#endif
    EmitOp( FC_CALL );
    OutPtr( itptr->sym_ptr );
    curr_obj = ObjTell();
    OutU16( 0 );
    if( (Options & OPT_DESCRIPTOR) == 0 ) {
        if( (sp->u.ns.flags & SY_SUBPROG_TYPE) == SY_FUNCTION ) {
            if( (sp->u.ns.flags & SY_INTRINSIC) == 0 ) {
                if( sp->u.ns.u1.s.typ == FT_CHAR ) {
                    OutPtr( GTempString( sp->u.ns.xt.size ) );
                }
            }
        }
    }
    num_args = DumpArgInfo( itptr->list );
    curr_obj = ObjSeek( curr_obj );
    OutU16( num_args );
    ObjSeek( curr_obj );
    if( (sp->u.ns.flags & SY_SUBPROG_TYPE) == SY_FUNCTION ) {
        if( sp->u.ns.u1.s.typ == FT_CHAR ) {
            if( (Options & OPT_DESCRIPTOR) || (sp->u.ns.flags & SY_INTRINSIC) ) {
                OutPtr( GTempString( sp->u.ns.xt.size ) );
            }
        }
    }
}
Exemple #5
0
void    EmitOp( FCODE value ) {
//===================================

// Emit the specified F-Code.

    OutU16( value  );
}
Exemple #6
0
void            GForceHiBound( int ss, sym_id sym ) {
//=======================================================

// Generate code to fill in ADV subscript element (hi bound).
// The hi bound is constant and the low bound is not.
// We have to force the filling in of the high bound so that the number of
// of elements gets computed.
//
// Scenario:   SUBROUTINE SAM( A, J )
//             DIMENSION A(J:3)
//
// GInitADV() fills in the lo bound and # of elements in the dimension at
// compile-time. The lo bound is unknown so the ADV does not contain the
// correct information. The lo bound gets filled in at run-time but
// since the hi bound is not dumped into the ADV at compile time we
// must fill it in at run-time and compute the correct number of elements
// in the dimension.

    AddConst( CITNode );
    PushOpn( CITNode );
    EmitOp( FC_ADV_FILL_HI );
    OutPtr( sym );
    OutU16( (uint_16)ss );
    GenType( CITNode );
}
Exemple #7
0
warp_label              GBegSList( void ) {
//===================================

// Generate code to start ADV initialization.

    EmitOp( FC_FCODE_SEEK );
    WarpLabel = ObjTell();
    OutU16( 0 );
    return( ObjTell() );
}
Exemple #8
0
label_id        GDataProlog( void ) {
//=============================

// Start off data statement code.

    EmitOp( FC_START_DATA_STMT );
    DtConstList = ObjTell();
    OutU16( 0 );
    return( 0 );
}
Exemple #9
0
void    OutInt( inttarg val ) {
//=============================

// Output target integer value to object memory.

#if _CPU == 8086
    OutU16( val );
#else // _CPU == 386
    OutConst32( val );
#endif
}
Exemple #10
0
void            GSLoBound( int ss, sym_id sym ) {
//===================================================

// Generate code to fill in ADV subscript element (lo bound).

    PushOpn( CITNode );
    EmitOp( FC_ADV_FILL_LO );
    OutPtr( sym );
    OutU16( (uint_16)ss );
    GenType( CITNode );
}
Exemple #11
0
void    GBegDList( void ) {
//===================

// Start list of data.

    unsigned_16 const_offset;
    obj_ptr     curr_obj;

    const_offset = ObjOffset( DtConstList );
    curr_obj = ObjSeek( DtConstList );
    OutU16( const_offset );
    ObjSeek( curr_obj );
}
Exemple #12
0
void    EndFmt( void ) {
//================

// Finish format processing.

    obj_ptr     fmt_ptr;
    unsigned_16 fmt_len;

    fmt_len = ObjOffset( FormatList ) - sizeof( unsigned_16 );
    fmt_ptr = ObjSeek( FormatList );
    OutU16( fmt_len );
    ObjSeek( fmt_ptr );
}
Exemple #13
0
void    GCheckEOF( label_id label ) {
//===================================

// Patch the label emitted by GNullEofStmt() to be the label at the end
// of the code of the ATEND statement.

    obj_ptr     curr_obj;

    curr_obj = ObjSeek( AtEndFCode );
    EmitOp( FC_SET_ATEND );
    OutU16( label );
    ObjSeek( curr_obj );
}
Exemple #14
0
void    StartFmt( cs_label fmt_label ) {
//======================================

// Start format processing.

    obj_ptr     new_fmt;

    EmitOp( FC_FCODE_SEEK );
    new_fmt = ObjTell();
    OutU16( 0 );
    OutObjPtr( FormatList );
    FormatList = new_fmt;
    if( StmtProc == PR_FMT ) {
        if( fmt_label.st_label == NULL ) {
            // FORMAT statement with no statement label
            OutU16( 0 );
        } else {
            OutU16( fmt_label.st_label->st.address );
        }
    } else {
        OutU16( fmt_label.g_label );
    }
}
Exemple #15
0
void            GEndSList( sym_id sym ) {
//=======================================

// Finish off ADV initialization.

    unsigned_16 warp_size;

    sym = sym;
    EmitOp( FC_WARP_RETURN );
    warp_size = ObjOffset( WarpLabel ) - sizeof( unsigned_16 );
    WarpLabel = ObjSeek( WarpLabel );
    OutU16( warp_size );
    ObjSeek( WarpLabel );
}
Exemple #16
0
void            GSHiBoundLo1( int ss, sym_id sym ) {
//======================================================

// Generate code to fill in ADV subscript element (hi bound).
// Set the low bound to 1.

    // push high bound value
    PushOpn( CITNode );
    EmitOp( FC_ADV_FILL_HI_LO_1 );
    // general information
    OutPtr( sym );
    OutU16( (uint_16)ss );
    GenType( CITNode );
}
Exemple #17
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 );
    }
}
Exemple #18
0
static  void    DoLoopEnd( void ) {
//===========================

// Generate code for end of DO-loops or implied-DO.

    do_entry    *doptr;

    doptr = CSHead->cs_info.do_parms;
    EmitOp( FC_DO_END );
    OutPtr( doptr->do_parm );
    OutPtr( doptr->increment );
    if( doptr->increment == NULL ) {
        OutConst32( doptr->incr_value );
    } else {
        OutPtr( doptr->iteration );
    }
    OutU16( CSHead->branch );
}
Exemple #19
0
static  int     DumpArgInfo( itnode *node ) {
//===========================================

// Dump argument types.

    int         num_args;
    unsigned_16 arg_info;
    PTYPE       parm_type;
    PCODE       parm_code;
#if _CPU == 386
    aux_info    *aux;
#endif

    num_args = 0;
    if( node != NULL ) {
        for(;;) {
            if( node->opr == OPR_COL )
                break;
            if( node->opr == OPR_RBR )
                break;
            if( node->opn.ds == DSOPN_PHI )
                break;
            if( node->opn.us != USOPN_STN ) {
                parm_type = ParmType( node->typ, node->size );
                parm_code = ParmClass( node );
#if _CPU == 386
                if( (parm_code == PC_PROCEDURE) || (parm_code == PC_FN_OR_SUB) ) {
                    aux = AuxLookup( node->sym_ptr );
                    if( aux->cclass & FAR16_CALL ) {
                        parm_code |= PC_PROC_FAR16;
                    }
                }
#endif
                arg_info = _SetTypeInfo( parm_code, parm_type );
                OutU16( arg_info );
                ++num_args;
            }
            node = node->link;
        }
    }
    return( num_args );
}
Exemple #20
0
void    GStopCat( uint num_args, sym_id result ) {
//===============================================

// Finish concatenation into a temporary.

    /* unused parameters */ (void)result;

    CITNode->sym_ptr = GTempString( CITNode->size );
    CITNode->opn.us = USOPN_VAL;
    // Push the address of a static SCB so that we can modify its
    // length to correspond to the length concatenated so that
    //      CHARACTER*5 WORD
    //      PRINT,LEN('1'//WORD(1:3))
    // prints 4 and not 6. The static SCB in this case initially
    // contains the length 6 ( len('1') + len(word) ) since generally
    // we don't know the length concatenated at compile time if WORD
    // was indexed as WORD(I:J).
    PushOpn( CITNode );
    EmitOp( FC_CAT );
    OutU16( (uint_16)( num_args | CAT_TEMP ) ); // indicate concatenating into a static temp
}
Exemple #21
0
void    GDataItem( itnode *rpt ) {
//================================

// Generate a data item.

    sym_id      data;
    intstar4    one;

    if( rpt == NULL ) {
        one = 1;
        data = STConst( &one, FT_INTEGER, TypeSize( FT_INTEGER ) );
    } else {
        data = rpt->sym_ptr;
    }
    OutPtr( data );
    if( CITNode->typ == FT_HEX ) {
        OutU16( PT_NOTYPE );
    } else {
        GenType( CITNode );
    }
    OutPtr( CITNode->sym_ptr );
}
Exemple #22
0
void    GEndCall( itnode *itptr, int num_stmts ) {
//================================================

// Finish off a subprogram invocation.

    itnode      *arg;

    if( num_stmts > 0 ) {
        EmitOp( FC_ALT_RET );
        OutU16( num_stmts );
        arg = itptr->list;
        for(;;) {
            if( (arg->opn.us & USOPN_WHAT) == USOPN_STN ) {
                GStmtAddr( arg->sym_ptr );
                num_stmts--;
            }
            arg = arg->link;
            if( num_stmts == 0 ) break;
        }
    } else if( (itptr->sym_ptr->u.ns.flags & SY_SUBPROG_TYPE) == SY_SUBROUTINE ) {
        EmitOp( FC_EXPR_DONE );
    }
    SetOpn( itptr, USOPN_SAFE );
}
Exemple #23
0
static  void    DoLoop( TYPE do_type ) {
//=====================================

// Generate code for DO statement or implied-DO.

    do_entry    *doptr;
    uint        do_size;
    intstar4    incr;
    intstar4    limit;
    sym_id      loop_ctrl;
    TYPE        e1_type;
    uint        e1_size;
    itnode      *e2_node;
    itnode      *e3_node;
    bool        e2_const;

    doptr = CSHead->cs_info.do_parms;
    do_size = CITNode->sym_ptr->u.ns.xt.size;
    doptr->do_parm = CITNode->sym_ptr;          // save ptr to do variable
    AdvanceITPtr();                             // bump past the '='
    EatDoParm();                                // process e1
    PushOpn( CITNode );
    e1_type = CITNode->typ;
    e1_size = CITNode->size;
    AdvanceITPtr();
    if( ReqComma() ) {
        EatDoParm();                            // process e2
        e2_const = CITNode->opn.us == USOPN_CON;
        PushOpn( CITNode );
        e2_node = CITNode;
        AdvanceITPtr();
        e3_node = NULL;
        if( RecComma() ) {
            EatDoParm();                        // process e3
            e3_node = CITNode;
            if( !AError ) {
                if( (CITNode->opn.us == USOPN_CON) && _IsTypeInteger( do_type ) ) {
                    incr = GetIntValue( CITNode );
                    doptr->incr_value = incr;
                    doptr->increment = NULL;
                    if( (OZOpts & OZOPT_O_FASTDO) == 0 ) {
                        if( e2_const ) {
                            limit = GetIntValue( e2_node );
                            if( NeedIncrement( limit, incr, do_type ) ) {
                                PushOpn( CITNode );
                                doptr->increment = StaticAlloc( do_size, do_type );
                            }
                        } else {
                            PushOpn( CITNode );
                            doptr->increment = StaticAlloc( do_size, do_type );
                        }
                    }
                } else {
                    PushOpn( CITNode );
                    doptr->increment = StaticAlloc( do_size, do_type );
                }
                AdvanceITPtr();
            }
        } else {
            if( _IsTypeInteger( do_type ) ) {
                doptr->increment = NULL;
                doptr->incr_value = 1;
                if( (OZOpts & OZOPT_O_FASTDO) == 0 ) {
                    if( e2_const ) {
                        limit = GetIntValue( e2_node );
                        if( NeedIncrement( limit, 1, do_type ) ) {
                            PushConst( 1 );
                            doptr->increment = StaticAlloc( do_size, do_type );
                        }
                    } else {
                        PushConst( 1 );
                        doptr->increment = StaticAlloc( do_size, do_type );
                    }
                }
            } else {
                PushConst( 1 );
                doptr->increment = StaticAlloc( do_size, do_type );
            }
        }
        EmitOp( FC_DO_BEGIN );
        OutPtr( doptr->do_parm );
        OutPtr( doptr->increment );
        if( doptr->increment == NULL ) { // INTEGER do-loop with constant incr
            loop_ctrl = StaticAlloc( do_size, do_type );
            OutConst32( doptr->incr_value );
            OutPtr( loop_ctrl );
        } else {
            if( _IsTypeInteger( do_type ) ) {
                loop_ctrl = StaticAlloc( do_size, do_type );
            } else {
                loop_ctrl = StaticAlloc( sizeof( intstar4 ), FT_INTEGER );
            }
            doptr->iteration = loop_ctrl;
            OutPtr( loop_ctrl );
            if( e3_node == NULL ) {
                DumpType( FT_INTEGER, TypeSize( FT_INTEGER ) );
            } else {
                GenType( e3_node );
            }
        }
        GenType( e2_node );
        DumpType( e1_type, e1_size );
        OutU16( CSHead->branch );
        OutU16( CSHead->bottom );
    }
}