rfmtutil.c

来自「开放源码的编译器open watcom 1.6.0版的源代码」· C语言 代码 · 共 993 行 · 第 1/2 页

/****************************************************************************
*
*                            Open Watcom Project
*
*    Portions Copyright (c) 1983-2002 Sybase, Inc. All Rights Reserved.
*
*  ========================================================================
*
*    This file contains Original Code and/or Modifications of Original
*    Code as defined in and that are subject to the Sybase Open Watcom
*    Public License version 1.0 (the 'License'). You may not use this file
*    except in compliance with the License. BY USING THIS FILE YOU AGREE TO
*    ALL TERMS AND CONDITIONS OF THE LICENSE. A copy of the License is
*    provided with the Original Code and Modifications, and is also
*    available at www.sybase.com/developer/opensource.
*
*    The Original Code and all software distributed under the License are
*    distributed on an 'AS IS' basis, WITHOUT WARRANTY OF ANY KIND, EITHER
*    EXPRESS OR IMPLIED, AND SYBASE AND ALL CONTRIBUTORS HEREBY DISCLAIM
*    ALL SUCH WARRANTIES, INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF
*    MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT OR
*    NON-INFRINGEMENT. Please see the License for the specific language
*    governing rights and limitations under the License.
*
*  ========================================================================
*
* Description:  Run-time formatted I/O utility routines
*
****************************************************************************/


#include "ftnstd.h"
#include "rundat.h"
#include "errcod.h"
#include "fmtdef.h"
#include "intcnv.h"
#include "target.h"
#include "pgmacc.h"
#include "undefrtn.h"
#include "fltcnv.h"
#include "fmath.h"
#include "rmemmgr.h"

#include <stdlib.h>
#include <ctype.h>
#include <limits.h>
#include <string.h>

extern  void            SendEOR(void);
extern  void            SendStr(char PGM *,uint);
extern  void            SendChar(char,int);
extern  void            Drop(char);
extern  void            NextRec(void);
extern  void            IOErr(int,...);
extern  void            R_F2F(extended,char *,int,int,bool,int);
extern  void            R_F2E(extended,char *,int,int,bool,int,int,char);
extern  int             FmtS2I(char *,int,bool,intstar4 *,bool,int *);
extern  int             FmtS2F(char *,int,int,bool,int,int,extended *,bool,int *,bool);
extern  void            *RChkAlloc(uint);
extern  void            SetMaxPrec(int);
extern  void            BToHS(char *,int,char *);
extern  byte            Hex(byte);
extern  void            CheckCCtrl(void);
extern  void            R_FmtLog(uint);
extern  bool            __AllowCommaSep(void);

#if defined( _M_IX86 ) || defined( __AXP__ ) || defined( __PPC__ )

extern  const double __FAR      P1d100;
extern  const double __FAR      P1d_99;

typedef union bit_extended {
    char        pattern[16];
    extended    value;
} bit_extended;

typedef union bit_double {
    char        pattern[8];
    double      value;
} bit_double;

typedef union bit_float {
    char        pattern[4];
    float       value;
} bit_float;

static  const bit_extended __FAR XInfinity =
                            {   0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
                                0xf0,0x7f,0x00,0x00,0x00,0x00,0x00,0x00 };
static  const bit_double __FAR  DInfinity =
                            { 0x00,0x00,0x00,0x00,0x00,0x00,0xf0,0x7f };
static  const bit_float __FAR   SInfinity = { 0x00,0x00,0x80,0x7f };

#endif

static  const byte __FAR        DataSize[] = {
            0,
            sizeof( logstar1 ),
            sizeof( logstar4 ),
            sizeof( intstar1 ),
            sizeof( intstar2 ),
            sizeof( intstar4 ),
            sizeof( single ),
            sizeof( double ),
            sizeof( extended ),
            sizeof( single ),
            sizeof( double ),
            sizeof( extended ) };


void    R_ChkType( PTYPE lower, PTYPE upper ) {
//===========================================

    if( ( IOCB->typ < lower ) || ( IOCB->typ > upper ) ) {
        IOErr( IO_FMT_MISMATCH );
    }
}


void    R_NewRec( void ) {
//==================

    if( IOCB->flags & IOF_OUTPT ) {
        IOCB->fileinfo->col = IOCB->fmtlen;
        CheckCCtrl();
        SendEOR();
        IOCB->fmtlen = IOCB->fileinfo->col;
    } else {
        NextRec();
    }
}


void    R_ChkIType( void ) {
//====================

// Check if type can be formatted using I format.

    if( ( IOCB->typ == PT_REAL_4 ) && ( IOCB->flags & IOF_EXTEND_FORMAT ) ) {
        // allow REAL variable containing integer data to be
        // formatted using I edit descriptor
        IOCB->typ = PT_INT_4;
    }
    R_ChkType( PT_INT_1, PT_INT_4 );
}


void    R_ChkFType( void ) {
//====================

// Check if type can be formatted using F, E, or D format.

    if( ( IOCB->typ == PT_INT_4 ) && ( IOCB->flags & IOF_EXTEND_FORMAT ) ) {
        // allow INTEGER variable containing floating-point data to be
        // formatted using F, E, or D edit descriptors
        IOCB->typ = PT_REAL_4;
    }
    R_ChkType( PT_REAL_4, PT_CPLX_32 );
}


void    R_ChkRecLen( void ) {
//=====================

    ftnfile     *fcb;

    fcb = IOCB->fileinfo;
    if( fcb->col > IOCB->fmtlen ) {
        IOCB->fmtlen = fcb->col;
    }
}


void    R_FOStr( void ) {
//=================

    FOString( IOCB->fmtptr->fmt4.fld1 );
}


uint    GetLen( void ) {
//================

    uint        len;

    if( IOCB->typ == PT_CHAR ) {
        len = IORslt.string.len;
    } else {
        len = DataSize[ IOCB->typ ];
    }
    return( len );
}


void    FOString( uint width ) {
//==============================

    ftnfile     *fcb;
    uint        length;

    fcb = IOCB->fileinfo;
    if( IOCB->typ != PT_CHAR ) {
        length = GetLen();
    } else {
        length = IORslt.string.len;
    }
    if( width == 0 ) {
        width = length;
    }
    if( fcb->col + width > fcb->bufflen ) {
        IOErr( IO_BUFF_LEN );
    }
    if( width > length ) {
        SendChar( ' ', width - length );
        width = length;
    }
    if( IOCB->typ == PT_CHAR ) {
        SendStrRtn( IORslt.string.strptr, width );
    } else {
        SendStrRtn( (char *)&IORslt, width );
    }
}


void    R_FIStr( void ) {
//=================

    uint        width;
    byte        blanks;
    uint        length;
    ftnfile     *fcb;
    char        *src;
    char        PGM *ptr;

    fcb   = IOCB->fileinfo;
    width = IOCB->fmtptr->fmt4.fld1;
    if( IOCB->typ != PT_CHAR ) {
        ptr = IORslt.pgm_ptr;
        length = GetLen();
    } else {
        ptr = IORslt.string.strptr;
        length = IORslt.string.len;
    }
    if( width == 0 ) {
        width = length;
    }
    if( width >= length ) {
        fcb->col += width - length;
        width = length;
    }
    ChkBuffLen( width );
    blanks = length - width;
    src = &fcb->buffer[ fcb->col ];
    pgm_memput( ptr, src, width );
    pgm_memset( ptr + width, ' ', blanks );
    fcb->col += width;
}


void    R_FOLog( void ) {
//=================

    if( UndefLogRtn() ) return;
    R_FmtLog( IOCB->fmtptr->fmt1.fld1 );
}


static  void    SetLogValue( logstar4 value ) {
//=============================================

    if( IOCB->typ == PT_LOG_1 ) {
        *(logstar1 PGM *)(IORslt.pgm_ptr) = value;
    } else {
        *(logstar4 PGM *)(IORslt.pgm_ptr) = value;
    }
}


void    R_FILog( void ) {
//=================

    ftnfile     *fcb;
    uint        width;
    char        ch;

    fcb = IOCB->fileinfo;
    width = IOCB->fmtptr->fmt1.fld1;
    ChkBuffLen( width );
    for(;;) {
        if( fcb->buffer[ fcb->col ] != ' ' ) break;
        fcb->col++;
        if( --width == 0 ) break;
    }
    if( fcb->buffer[ fcb->col ] == '.' ) {
         --width;
         fcb->col++;
    }
    if( width == 0 ) {
        IOErr( IO_BAD_CHAR );
    } else {
        ch = toupper( fcb->buffer[ fcb->col ] );
        if( ch == 'F' ) {
            SetLogValue( _LogValue( FALSE ) );
        } else if( ch == 'T' ) {
            SetLogValue( _LogValue( TRUE ) );
        }
    }
    if( __AllowCommaSep() ) { // don't flush but search for comma separator
        fcb->col++;
        width--;
        while( width > 0 ) {
            if( fcb->buffer[ fcb->col ] == ',' ) {
                fcb->col++;
                break;
            }
            fcb->col++;
            width--;
        }
    } else {
        fcb->col += width; // flush over other stuff
    }
}


void    R_FIFloat( void ) {
//===================

// Input an real or complex variable in D, E, F, G format.

    extended     value;
    fmt2 PGM    *fmtptr;
    ftnfile     *fcb;
    PTYPE       typ;
    int         prec;
    int         status;
    bool        comma;
    int         width;

    fcb = IOCB->fileinfo;
    fmtptr = &IOCB->fmtptr->fmt2;
    typ = IOCB->typ;
    ChkBuffLen( fmtptr->fld1 );
    switch( typ ) {
    case( PT_REAL_8 ):
    case( PT_CPLX_16 ):
        prec = PRECISION_DOUBLE;
        break;
    case( PT_REAL_16 ):
    case( PT_CPLX_32 ):
        prec = PRECISION_EXTENDED;
        break;
    default:
        prec = PRECISION_SINGLE;
    };
    comma = __AllowCommaSep();
    status = FmtS2F( &fcb->buffer[ fcb->col ], fmtptr->fld1,
                     fmtptr->fld2, ( fcb->blanks == BLANK_ZERO ),
                     IOCB->scale, prec, &value, comma, &width, FALSE );
    if( status == FLT_OK ) {
        if( comma && ( fmtptr->fld1 != width ) ) {
            fcb->col += width;
            if( fcb->buffer[ fcb->col ] == ',' ) {
                fcb->col++;
            } else {
                IOErr( IO_BAD_CHAR );
            }
        } else {
            fcb->col += fmtptr->fld1;
        }
        if( typ  == PT_REAL_4 ) {
            *(single PGM *)(IORslt.pgm_ptr) = value;
        } else if( typ  == PT_REAL_8 ) {
            *(double PGM *)(IORslt.pgm_ptr) = value;
        } else if( typ  == PT_REAL_16 ) {
            *(extended PGM *)(IORslt.pgm_ptr) = value;
        } else if( typ  == PT_CPLX_8 ) {
            if( IOCB->flags & IOF_FMTREALPART ) {
                ((complex PGM *)(IORslt.pgm_ptr))->realpart = value;
            } else {
                ((complex PGM *)(IORslt.pgm_ptr))->imagpart = value;
            }
        } else if( typ  == PT_CPLX_16 ) {
            if( IOCB->flags & IOF_FMTREALPART ) {
                ((dcomplex PGM *)(IORslt.pgm_ptr))->realpart = value;
            } else {
                ((dcomplex PGM *)(IORslt.pgm_ptr))->imagpart = value;
            }
        } else {
            if( IOCB->flags & IOF_FMTREALPART ) {
                ((xcomplex PGM *)(IORslt.pgm_ptr))->realpart = value;
            } else {
                ((xcomplex PGM *)(IORslt.pgm_ptr))->imagpart = value;
            }
        }
    } else {
        if( status == FLT_INVALID ) {
            IOErr( IO_BAD_CHAR );
        } else { // FLT_RANGE_EXCEEDED
            IOErr( IO_FRANGE_EXCEEDED );
        }
    }
}


bool    GetReal( extended *value ) {
//================================

    PTYPE       typ;
    single      *short_flt;
    bool        defined;

    typ = IOCB->typ;
    if( ( typ == PT_REAL_4  ) || ( typ == PT_CPLX_8 ) ) {
        SetMaxPrec( MAX_SP );
        if( typ  == PT_REAL_4 ) {
            short_flt = &IORslt.single;
        } else if( IOCB->flags & IOF_FMTREALPART ) {     // PT_CPLX_8
            short_flt = &IORslt.complex.realpart;
        } else {
            short_flt = &IORslt.complex.imagpart;
        }
        *value = *short_flt;
        defined = !UndefRealRtn( short_flt );
    } else if( ( typ == PT_REAL_8 ) || ( typ == PT_CPLX_16 ) ) {
        SetMaxPrec( MAX_DP );
        if( typ == PT_REAL_8 ) {
            *value = IORslt.dble;
        } else if( IOCB->flags & IOF_FMTREALPART ) {    // PT_CPLX_16
            *value = IORslt.dcomplex.realpart;
        } else {
            *value = IORslt.dcomplex.imagpart;
        }
        defined = !UndefDoubleRtn( value );
    } else {
        SetMaxPrec( MAX_XP );
        if( typ == PT_REAL_16 ) {
            *value = IORslt.extended;
        } else if( IOCB->flags & IOF_FMTREALPART ) {    // PT_CPLX_32
            *value = IORslt.xcomplex.realpart;
        } else {
            *value = IORslt.xcomplex.imagpart;
        }
        defined = !UndefExtendedRtn( value );
    }
    return( defined );
}


void    R_FOF( void ) {
//===============

    ftnfile     *fcb;
    fmt2 PGM    *fmt;
    char        *buf;
    uint        wid;
    extended    val;

    fcb = IOCB->fileinfo;
    buf = &fcb->buffer[ fcb->col ];
    fmt = &IOCB->fmtptr->fmt2;
    wid = fmt->fld1;
    if( GetRealRtn( &val, wid ) ) {
        R_F2F( val, buf, wid, fmt->fld2, (IOCB->flags & IOF_PLUS) != 0,
               IOCB->scale );
    }
    fcb->col += wid;
}


void    R_FOE( int exp, char ch ) {
//=================================

    ftnfile     *fcb;
    fmt3 PGM    *fmt;
    char        *buf;
    uint        wid;
#if defined( _M_IX86 ) || defined( __AXP__ ) || defined( __PPC__ )
    extended      absvalue;
#endif
    extended      value;
    extended      bot;
    extended      top;

    fcb = IOCB->fileinfo;
    buf = &fcb->buffer[ fcb->col ];
    fmt = &IOCB->fmtptr->fmt3;
    wid = fmt->fld1;
    if( GetRealRtn( &value, wid ) ) {
        // if Ew.d or Dw.d format, exp == 0
        // (i.e. exponent width not specified)
        if( exp == 0 ) {
#if defined( _M_IX86 ) || defined( __AXP__ ) || defined( __PPC__ )
            absvalue = value;
            if( value < 0.0 ) {
                absvalue = -value;
            }