fcio.c

来自「开放源码的编译器open watcom 1.6.0版的源代码」· C语言 代码 · 共 1,296 行 · 第 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:  F-Code I/O routines.
*
****************************************************************************/


#include "ftnstd.h"
#include "global.h"
#include "fcdata.h"
#include "wf77defs.h"
#include "wf77cg.h"
#include "tmpdefs.h"
#include "rtconst.h"
#include "types.h"
#include "emitobj.h"
#include "fctypes.h"

//=================== Back End Code Generation Routines ====================

extern  void            CGDone(cg_name);
extern  cg_name         CGInteger(signed_32,cg_type);
extern  void            CGAddParm(call_handle,cg_name,cg_type);
extern  cg_name         CGCall(call_handle);
extern  cg_name         CGBackName(back_handle,cg_type);
extern  cg_name         CGFEName(sym_handle,cg_type);
extern  cg_name         CGUnary(cg_op,cg_name,cg_type);
extern  cg_name         CGBinary(cg_op,cg_name,cg_name,cg_type);
extern  void            CGTrash(cg_name);
extern  cg_name         CGAssign(cg_name,cg_name,cg_type);
extern  void            CGControl(cg_op,cg_name,label_handle);
extern  cg_name         CGCompare(cg_op,cg_name,cg_name,cg_type);
extern  void            CG3WayControl(cg_name,label_handle,label_handle,
                                      label_handle );
extern  label_handle    BENewLabel(void);
extern  void            BEFiniLabel(label_handle);

//=========================================================================

extern  call_handle     InitCall(RTCODE);
extern  cg_name         XPop(void);
extern  cg_name         XPopValue(cg_type);
extern  void            XPopCmplx(cg_cmplx *,cg_type);
extern  cg_name         GetTypedValue(void);
extern  void            XPush(cg_name);
extern  cg_name         SymAddr(sym_id);
extern  cg_type         SymPtrType(sym_id);
extern  cg_name         ImagPtr(cg_name,cg_type);
extern  back_handle     GetFmtLabel(label_id);
extern  cg_name         ArrayEltSize(sym_id);
extern  cg_name         ArrayNumElts(sym_id);
extern  cg_name         FieldArrayNumElts(sym_id);
extern  label_handle    GetLabel(int);
extern  cg_name         SCBLenAddr(cg_name);
extern  cg_name         SCBPtrAddr(cg_name);
extern  label_handle    GetStmtLabel(sym_id);
extern  void            RefStmtLabel(sym_id);
extern  cg_type         CmplxBaseType(cg_type);
extern  void            CloneCGName(cg_name,cg_name *,cg_name *);
extern  tmp_handle      MkTmp(cg_name,cg_type);
extern  cg_name         TmpPtr(tmp_handle,cg_type);
extern  cg_name         TmpVal(tmp_handle,cg_type);
extern  void            ReverseList(void **);

static  void            StructIOArrayStruct( sym_id arr );
static  void            StructIOItem( sym_id fd );

static  sym_id          EndEqStmt;
static  sym_id          ErrEqStmt;
static  void            (**IORtnTable)(void);
static  tmp_handle      TmpStructPtr;
static  bool            IOStatSpecified;
static  label_handle    IOSLabel;
static  bool            NmlSpecified;


static  void    ChrArrayIO( RTCODE rtn, cg_name arr, cg_name num_elts,
                            cg_name elt_size ) {
//====================================================================

    call_handle call;

    call = InitCall( rtn );
    CGAddParm( call, elt_size, T_INTEGER );
    CGAddParm( call, num_elts, T_INT_4 );
    CGAddParm( call, arr, T_POINTER );
    CGDone( CGCall( call ) );
}


static  void    NumArrayIO( RTCODE rtn, cg_name arr, cg_name num_elts,
                            uint typ ) {
//====================================================================

    call_handle call;

    call = InitCall( rtn );
    CGAddParm( call, CGInteger( typ, T_INTEGER ), T_INTEGER );
    CGAddParm( call, num_elts, T_INT_4 );
    CGAddParm( call, arr, T_POINTER );
    CGDone( CGCall( call ) );
}


static  void    IOCall( RTCODE rtn ) {
//====================================

// Call i/o run-time routine with one argument.

    call_handle handle;

    handle = InitCall( rtn );
    CGAddParm( handle, XPop(), T_POINTER );
    CGDone( CGCall( handle ) );
}


static  void    IOCallValue( RTCODE rtn ) {
//=========================================

// Call i/o run-time routine with one argument.

    call_handle handle;

    handle = InitCall( rtn );
    CGAddParm( handle, GetTypedValue(), T_INT_4 );
    CGDone( CGCall( handle ) );
}


static  void    ChkIOErr( cg_name io_stat ) {
//===========================================

// Check for i/o errors.

    label_handle        eq_label;

    io_stat = CGUnary( O_POINTS, io_stat, T_INTEGER );
    if( ( EndEqLabel != 0 ) && ( ErrEqLabel != 0 ) ) {
        eq_label = BENewLabel();
        CG3WayControl( io_stat, GetLabel( EndEqLabel ), eq_label,
                       GetLabel( ErrEqLabel ) );
        CGControl( O_LABEL, NULL, eq_label );
        BEFiniLabel( eq_label );
    } else if( EndEqLabel != 0 ) {
        CGControl( O_IF_TRUE,
                   CGCompare( O_LT, io_stat, CGInteger( 0, T_INTEGER ),
                              T_INTEGER ),
                   GetLabel( EndEqLabel ) );
    } else if( ErrEqLabel != 0 ) {
        CGControl( O_IF_TRUE,
                   CGCompare( O_NE, io_stat, CGInteger( 0, T_INTEGER ),
                              T_INTEGER ),
                   GetLabel( ErrEqLabel ) );
    } else if( IOStatSpecified ) {
        IOSLabel = BENewLabel();
        CGControl( O_IF_TRUE,
                   CGCompare( O_NE, io_stat, CGInteger( 0, T_INTEGER ),
                              T_INTEGER ),
                   IOSLabel );
    } else {
        CGDone( io_stat );
    }
}


static  void    StructIO( struct field *fd ) {
//============================================

    sym_id      map;
    sym_id      big_map;
    unsigned_32 size;

    while( fd != NULL ) {
        if( fd->typ == TY_STRUCTURE ) {
            if( fd->dim_ext != NULL ) {
                StructIOArrayStruct( (sym_id)fd );
            } else {
                StructIO( fd->xt.record->fl.fields );
            }
        } else if( fd->typ == TY_UNION ) {
            size = 0;
            map = fd->xt.sym_record;
            while( map != NULL ) { // find biggest map
                if( map->sd.size > size ) {
                    size = map->sd.size;        // 91/08/01 DJG
                    big_map = map;
                }
                map = map->sd.link;
            }
            StructIO( big_map->sd.fl.fields );
        } else {
            StructIOItem( (sym_id)fd );
        }
        fd = &fd->link->fd;
    }
}


static  void    IOStatement( RTCODE stmt ) {
//==========================================

    // don't need label generated for IOSTAT unless it's a READ or WRITE
    // statement that is not NAMELIST-directed
    if( ( (stmt != RT_EX_READ) && (stmt != RT_EX_WRITE) ) || NmlSpecified ) {
        IOStatSpecified = FALSE;
    }
    ChkIOErr( CGCall( InitCall( stmt ) ) );
}


static  void    Output( RTCODE rtn, cg_type arg_type ) {
//======================================================

// Call runtime routine to output elemental types value.

    call_handle handle;

    handle = InitCall( rtn );
    CGAddParm( handle, XPopValue( arg_type ), PromoteToBaseType( arg_type ) );
    CGDone( CGCall( handle ) );
}


static  void    Input( RTCODE rtn ) {
//===================================

// Common input routine.

    call_handle handle;

    handle = InitCall( rtn );
    CGAddParm( handle, XPop(), T_POINTER );
    CGDone( CGCall( handle ) );
}


void    FCSetIOCB( void ) {
//===================

// Call runtime routine to set i/o statement in IOCB.
// This must be the first call when processing an I/O statement.

    EndEqLabel = 0;
    ErrEqLabel = 0;
    EndEqStmt = NULL;
    ErrEqStmt = NULL;
    IOStatSpecified = FALSE;
    NmlSpecified = FALSE;
}


void    FCSetUnit( void ) {
//===================

// Call runtime routine to set unit number in IOCB.

    IOCallValue( RT_SET_UNIT );
}


void    FCExRead( void ) {
//==================

// Call runtime routine to set start READ operation.

    IOStatement( RT_EX_READ );
}


void    FCExWrite( void ) {
//===================

// Call runtime routine to set start WRITE operation.

    IOStatement( RT_EX_WRITE );
}


void    FCExOpen( void ) {
//==================

// Call runtime routine to set start OPEN operation.

    IOStatement( RT_EX_OPEN );
}


void    FCExClose( void ) {
//===================

// Call runtime routine to set start CLOSE operation.

    IOStatement( RT_EX_CLOSE );
}


void    FCExBack( void ) {
//==================

// Call runtime routine to set start BACKSPACE operation.

    IOStatement( RT_EX_BACK );
}


void    FCExEndf( void ) {
//==================

// Call runtime routine to set start ENDFILE operation.

    IOStatement( RT_EX_ENDF );
}


void    FCExRew( void ) {
//=================

// Call runtime routine to set start REWIND operation.

    IOStatement( RT_EX_REW );
}


void    FCExInq( void ) {
//=================

// Call runtime routine to set start INQUIRE operation.

    IOStatement( RT_EX_INQ );
}


void    FCOutLOG1( void ) {
//===================

// Call runtime routine to output LOGICAL*1 value.

    Output( RT_OUT_LOG1, T_UINT_1 );
}


void    FCOutLOG4( void ) {
//===================

// Call runtime routine to output LOGICAL*4 value.

    Output( RT_OUT_LOG4, T_UINT_4 );
}


void    FCOutINT1( void ) {
//===================

// Call runtime routine to output INTEGER*1 value.

    Output( RT_OUT_INT1, T_INT_1 );
}


void    FCOutINT2( void ) {
//===================

// Call runtime routine to output INTEGER*2 value.

    Output( RT_OUT_INT2, T_INT_2 );
}


void    FCOutINT4( void ) {
//===================

// Call runtime routine to output INTEGER*4 value.

    Output( RT_OUT_INT4, T_INT_4 );
}


void    FCOutREAL( void ) {
//===================

// Call runtime routine to output REAL*4 value.

    Output( RT_OUT_REAL, T_SINGLE );
}


void    FCOutDBLE( void ) {
//===================

// Call runtime routine to output REAL*8 value.

    Output( RT_OUT_DBLE, T_DOUBLE );
}


void    FCOutXTND( void ) {
//===================

// Call runtime routine to output REAL*10 value.

    Output( RT_OUT_XTND, T_LONGDOUBLE );
}


static  void    OutCplx( RTCODE rtn, cg_type typ ) {
//===============================================

// Call runtime routine to input COMPLEX value.

    call_handle handle;
    cg_cmplx    z;

    handle = InitCall( rtn );
    XPopCmplx( &z, typ );
    typ = CmplxBaseType( typ );
    CGAddParm( handle, z.imagpart, typ );
    CGAddParm( handle, z.realpart, typ );
    CGDone( CGCall( handle ) );
}


void    FCOutCPLX( void ) {
//===================

// Call runtime routine to output COMPLEX*8 value.

    OutCplx( RT_OUT_CPLX, T_COMPLEX );
}


void    FCOutDBCX( void ) {
//===================

// Call runtime routine to output COMPLEX*16 value.

    OutCplx( RT_OUT_DBCX, T_DCOMPLEX );
}


void    FCOutXTCX( void ) {
//===================

// Call runtime routine to output COMPLEX*20 value.

    OutCplx( RT_OUT_XTCX, T_XCOMPLEX );
}


void    FCOutCHAR( void ) {
//===================

// Call runtime routine to output CHARACTER*n value.

    call_handle handle;

    handle = InitCall( RT_OUT_CHAR );
    CGAddParm( handle, XPop(), T_POINTER );
    CGDone( CGCall( handle ) );
}


static  void    IOString( RTCODE rtn ) {
//======================================

    call_handle handle;

    handle = InitCall( rtn );
    CGAddParm( handle, XPop(), T_INTEGER );
    CGAddParm( handle, XPop(), T_POINTER );
    CGDone( CGCall( handle ) );
}


static  void    OutString( void ) {
//===========================

// Call runtime routine to output CHARACTER*n value.
// Note: 2 arguments are passed (data pointer and length) as opposed to a
//       pointer to the SCB.

    IOString( RT_OUT_STR );
}


void    FCInpLOG1( void ) {
//===================

// Call runtime routine to input LOGICAL*1 value.

    Input( RT_INP_LOG1 );
}


void    FCInpLOG4( void ) {
//===================

// Call runtime routine to input LOGICAL*4 value.

    Input( RT_INP_LOG4 );
}


void    FCInpINT1( void ) {
//===================

// Call runtime routine to input INTEGER*1 value.

    Input( RT_INP_INT1 );
}


void    FCInpINT2( void ) {
//===================

// Call runtime routine to input INTEGER*2 value.

    Input( RT_INP_INT2 );
}


void    FCInpINT4( void ) {
//===================

// Call runtime routine to input INTEGER*4 value.

    Input( RT_INP_INT4 );
}


void    FCInpREAL( void ) {
//===================

// Call runtime routine to input REAL*4 value.

    Input( RT_INP_REAL );
}


void    FCInpDBLE( void ) {
//===================

// Call runtime routine to input REAL*8 value.

    Input( RT_INP_DBLE );
}


void    FCInpXTND( void ) {
//===================

// Call runtime routine to input REAL*10 value.

    Input( RT_INP_XTND );
}


void    FCInpCPLX( void ) {
//===================

// Call runtime routine to input COMPLEX*8 value.

    Input( RT_INP_CPLX );
}


void    FCInpDBCX( void ) {
//===================

// Call runtime routine to input COMPLEX*16 value.

    Input( RT_INP_DBCX );
}


void    FCInpXTCX( void ) {
//===================

// Call runtime routine to input COMPLEX*20 value.

    Input( RT_INP_XTCX );
}


void    FCInpCHAR( void ) {
//===================

// Call runtime routine to input CHARACTER*n value.

    Input( RT_INP_CHAR );
}


static  void    InpString( void ) {
//===========================

// Call runtime routine to input CHARACTER*n value.
// Note: 2 arguments are passed (data pointer and length) as opposed to a
//       pointer to the SCB.

    IOString( RT_INP_STR );
}


void    FCEndIO( void ) {
//=================

// Call runtime routine to terminate i/o processing.

    CGDone( CGCall( InitCall( RT_ENDIO ) ) );
    FCChkIOStmtLabel();
    if( ( ErrEqLabel == 0 ) && ( EndEqLabel == 0 ) && IOStatSpecified ) {
        CGControl( O_LABEL, NULL, IOSLabel );
        BEFiniLabel( IOSLabel );
    }
}


static  void            (*OutRtn[])(void) = {
        NULL,
        &FCOutLOG1,
        &FCOutLOG4,
        &FCOutINT1,
        &FCOutINT2,