pgqa.gml

开放源码的编译器open watcom 1.6.0版的源代码

.ix 'formatted'
.ix 'fixed record type'
The &cmpname allows for three types of binary data file formats:
.begbull
.bull
Variable length, unformatted sequential access binary records,
.bull
Fixed length, unformatted direct access binary records, and
.bull
Unformatted, sequential, binary data with a fixed record type.
.endbull
.np
Variable length binary records are preceded by a four byte
descriptor that indicates
the length of the record in bytes.
The end of the binary record is
also marked by another descriptor tag specifying the length.
Binary records that are of a fixed length are kept in a direct access,
unformatted file.
Refer to the
.book &cmpname User's Guide
section on File Handling for more information on file formats.
.np
Binary data files that have no structure or record length information
may be read if you open the file as a sequential, unformatted file
with a fixed record type.
This allows you to read files that contain a stream of binary data
without any inherent record format.
If you know the type of data that is contained in the binary file, you
may then read the binary data directly into variables.
The following program provides an example of reading binary stream
data.
.millust begin
* BINDATA.FOR - This program demonstrates how to read a
* binary data file that does not have any defined records.

      program bindata

      integer BinArray(20)
      integer i

      open( unit=1, file='bindata.fil',
     +      access='sequential',
     +      form='unformatted',
     +      recordtype='fixed' )

*  Read 20 integers from the binary data file
      do i = 1, 20
         read( 1 ) BinArray( i )
      end do

*  Write the extracted values to standard output
      do i = 1, 20
         write( *, * ) BinArray( i )
      end do
      end
.millust end
.*
.do end
.*
.if '&lang' eq 'FORTRAN 77' .do begin
.*
.section Redefining math error handling with &cmpname
.*
.np
.ix 'math errors'
If you wish to customize math error handling for your application, you
can create your own math error handling procedure.
The following illustrates the procedures for trapping errors by way of
an example.
See the
.book &cmpname User's Guide
for a description of the
.kw fsignal
subroutine and math library error handling.
.np
The main program example "MATHDEMO" is a FORTRAN program that contains
a floating-point divide by zero error,
a floating-point overflow error,
a floating-point underflow error, and
an invalid argument to a math library function.
.code begin
      program mathdemo

* MATHDEMO.FOR - This program forms part of a collection of FORTRAN
*                code that demonstrates how to take over control of
*                math error handling from the run-time system.

* Compile: wfl[386] mathdemo cw87 _matherr

.code break
* Notes:
* (1) We call "cw87" to enable underflow exceptions which are
*     masked (ignored) by default.
* (2) The signal handler must be re-installed after each signal
*     (it can also be re-installed even when there is no signal).
* (3) To prevent compile-time constant folding in expressions,
*     we add log(1.0) which is 0.  We do this for the sake of
*     demonstrating exception handling.

      implicit none

      double precision x, y, z

      call cw87         ! init 80x87 control word

.code break
      call resetFPE     ! install signal handler
      print *, ' '
      print *, 'Divide by zero will be attempted'
      x = 1.0d0 + DLOG( 1.0d0 )
      y = 0.0d0
      z = x / y
      call chkFPE       ! check for exception
      print *, z

.code break
      call resetFPE     ! install signal handler
      print *, ' '
      print *, 'Overflow will be attempted'
      x = 1.2d300 + DLOG( 1.0d0 )
      y = 1.2d300
      z = x * y
      call chkFPE       ! check for exception
      print *, z

.code break
      call resetFPE     ! install signal handler
      print *, ' '
      print *, 'Underflow will be attempted'
      x = 1.14d-300 + DLOG( 1.0d0 )
      y = 2.24d-308
      z = x * y
      call chkFPE       ! check for exception
      print *, z

.code break
      call resetFPE     ! install signal handler
      print *, ' '
      print *, 'Math error will be attempted'
      x = -12.0
      ! an exception will not be generated since the intrinsic function
      ! will validate the argument - if you compile with /om, the "fsqrt"
      ! 80x87 instruction will be generated in-line and an exception
      ! will occur
      y = SQRT( x )
      call chkFPE       ! check for exception
      print *, x, y
      end

.code break
      subroutine resetFPE
      include 'fsignal.fi'
      external fpe_handler
      logical fpe_flag
      integer fpe_sig, fpe_fpe
      common fpe_flag, fpe_sig, fpe_fpe
      fpe_flag = .false.
      call fsignal( SIGFPE, fpe_handler )
      end

.code break
*$pragma aux fpe_handler parm( value )

      subroutine fpe_handler( sig, fpe )
      integer sig, fpe
      logical fpe_flag
      integer fpe_sig, fpe_fpe
      common fpe_flag, fpe_sig, fpe_fpe
      fpe_flag = .true.
      fpe_sig = sig
      fpe_fpe = fpe
      end

.code break
*$pragma aux fwait = "fwait"

      subroutine chkFPE
      include 'fsignal.fi'
      logical fpe_flag
      integer fpe_sig, fpe_fpe
      common fpe_flag, fpe_sig, fpe_fpe
* Notes:
* (1) An fwait is required to make sure that the last
*     floating-point instruction has completed.
* (2) "volatile" is not needed here but would be
*     needed in main program if it references "fpe_flag"
      call fwait()
.code break
      if( volatile( fpe_flag ) ) then
        print *, '*ERROR* exception occurred',
     &           fpe_sig, fpe_fpe
        if( fpe_fpe .eq. FPE_INVALID )then
          print *, 'Invalid'
        else if( fpe_fpe .eq. FPE_DENORMAL )then
          print *, 'Denormalized operand error'
        else if( fpe_fpe .eq. FPE_ZERODIVIDE )then
          print *, 'Divide by zero error'
        else if( fpe_fpe .eq. FPE_OVERFLOW )then
          print *, 'Overflow error'
        else if( fpe_fpe .eq. FPE_UNDERFLOW )then
          print *, 'Underflow error'
        else if( fpe_fpe .eq. FPE_INEXACT )then
          print *, 'Inexact result (precision)then error'
        else if( fpe_fpe .eq. FPE_UNEMULATED )then
          print *, 'Unemulated instruction error'
        else if( fpe_fpe .eq. FPE_SQRTNEG )then
          print *, 'Square root of a negative number error'
        else if( fpe_fpe .eq. FPE_STACKOVERFLOW )then
          print *, 'NDP stack overflow error'
        else if( fpe_fpe .eq. FPE_STACKUNDERFLOW )then
          print *, 'NDP stack underflow error'
        else if( fpe_fpe .eq. FPE_EXPLICITGEN )then
          print *, 'SIGFPE signal raised (software)'
        else if( fpe_fpe .eq. FPE_IOVERFLOW )then
          print *, 'Integer overflow error'
        endif
      else
        print *, '*OK* no exception occurred'
      endif
      end
.code end
.np
The following subroutine illustrates how to enable or disable
particular types of floating-point exceptions.
.code begin
      subroutine cw87

* CW87.FOR
* This subroutine uses the C Library routine "_control87"
* to modify the math coprocessor exception mask.

.code break
* Compile: wfc[386] cw87

      include 'fsignal.fi'

      character*9 status(0:1)/' disabled',' enabled'/
      integer fp_cw, fp_mask, bits, i

.code break
* Enable floating-point underflow since default is disabled.
* The mask defines which bits we want to change (1 means change,
* 0 means do not change).  The corresponding bit in the control
* word (fp_cw) is set to 0 to enable the exception or 1 to disable
* the exception.  In this example, we change only the underflow
* bit and leave the others unchanged.

      fp_mask = EM_UNDERFLOW    ! mask for the bits to set/reset
      fp_cw = '0000'x           ! new bit settings (0=enable/1=disable)
      fp_cw = _control87( fp_cw, fp_mask )

.code break
* Now get up-to-date setting

      fp_cw = _control87( 0, 0 )

      bits = IAND( fp_cw, MCW_EM )
      print '(a,1x,z4)', 'Interrupt Exception Mask', bits
.code break
      i = 0
      if( IAND(fp_cw, EM_INVALID) .eq. 0 ) i = 1
      print *, '  Invalid Operation exception', status(i)
.code break
      i = 0
      if( IAND(fp_cw, EM_DENORMAL) .eq. 0 ) i = 1
      print *, '  Denormalized exception', status(i)
.code break
      i = 0
      if( IAND(fp_cw, EM_ZERODIVIDE) .eq. 0 ) i = 1
      print *, '  Divide-By-Zero exception', status(i)
.code break
      i = 0
      if( IAND(fp_cw, EM_OVERFLOW) .eq. 0 ) i = 1
      print *, '  Overflow exception', status(i)
.code break
      i = 0
      if( IAND(fp_cw, EM_UNDERFLOW) .eq. 0 ) i = 1
      print *, '  Underflow exception', status(i)
.code break
      i = 0
      if( IAND(fp_cw, EM_PRECISION) .eq. 0 ) i = 1
      print *, '  Precision exception', status(i)
      end
.code end
.np
The following subroutine illustrates how to replace the run-time
system's math error handler.
Source code similar to this example is provided with the software
(look for the file
.fi _matherr.for
.ct ).
.code begin
*
* _MATHERR.FOR  : math error handler
*
* Compile: wfc[386] _matherr

*$pragma aux __imath2err "*_" parm( value, reference, reference )
*$pragma aux __amath1err "*_" parm( value, reference )
*$pragma aux __amath2err "*_" parm( value, reference, reference )
*$pragma aux __math1err "*_" parm( value, reference )
*$pragma aux __math2err "*_" parm( value, reference, reference )
*$pragma aux __zmath2err "*_" parm( value, reference, reference )
*$pragma aux __qmath2err "*_" parm( value, reference, reference )


.code break
      integer function __imath2err( err_info, arg1, arg2 )
      integer err_info
      integer arg1, arg2
      include 'mathcode.fi'
      arg1 = arg1     ! to avoid unreferenced warning message
      arg2 = arg2     ! to avoid unreferenced warning message
      if( ( err_info .and. M_DOMAIN ) .ne. 0 )then
          select( err_info .and. FUNC_MASK )
          case( FUNC_POW )
              print *, 'arg2 cannot be <= 0'
          case( FUNC_MOD )
              print *, 'arg2 cannot be 0'
          end select
      end if
      __imath2err = 0
      end


.code break
      real function __amath1err( err_info, arg1 )
      integer err_info
      real arg1
      include 'mathcode.fi'
      arg1 = arg1     ! to avoid unreferenced warning message
      if( ( err_info .and. M_DOMAIN ) .ne. 0 )then
          select( err_info .and. FUNC_MASK )
          case( FUNC_COTAN )
              print *, 'overflow'
          end select
      end if
      __amath1err = 0.0
      end


.code break
      real function __amath2err( err_info, arg1, arg2 )
      integer err_info
      real arg1, arg2
      include 'mathcode.fi'
      arg1 = arg1     ! to avoid unreferenced warning message
      arg2 = arg2     ! to avoid unreferenced warning message
      if( ( err_info .and. M_DOMAIN ) .ne. 0 )then
          select( err_info .and. FUNC_MASK )
          case( FUNC_MOD )
              print *, 'arg2 cannot be 0'
          end select
      end if
      __amath2err = 0.0
      end


.code break
      double precision function __math1err( err_info, arg1 )
      integer err_info
      double precision arg1, __math2err
      __math1err = __math2err( err_info, arg1, arg1 )
      end