紹介しましたincludeですが、不具合が見つかりました。調べてみると、fgetc(),fputc()に原因がありました。不具合を改善したfgetc(),fputc()を掲載します。 これに関連して、files.fi,initfile(),fopen()も変更が必要です。

変更点は、以下の通りです。

1. 最後の文字位置をlastcr,lastcwで記憶
2. READWRITEでファイルを開けられるように対応
3. fnewで改行を超えたことを明示
4. getlin(),putlin()のバッファーをMAXLINE+1に変更

まずは、files.fi。

c files.fi -- file interface common valiables
      common /files/finuse(20),fbuf(20,81),flastcr(20),flastcw(20),
     1              fmode(20),fnew(20)
                          ! MAXFILES(20) MAXLINE(81)
      integer finuse      ! inuse flag
      integer*1 fbuf      ! I/O buffer
      integer flastcr     ! characters in read buffer
      integer flastcw     ! characters in write buffer
      integer*1 fmode     ! READ/WIRTE flag
      integer fnew        ! NEWLINE flag

変数、flastcに代わって、flastcr,flastcwを使用します。これは、READWRITEでファイルを開けた時に、正常に動作するようにするためです。 また、fnewを追加しました。これは、NEWLINEを超えた時にセットされ、次行を読み込むスイッチになります。

fopen()です。

c fopen.for -- connect intenal file descripter and external file
      integer function fopen(uid, fn, act)
      integer uid
      integer*1 fn(*), act
      integer i
      character*81 cfn                  ! MAXNAME(81)
      character*9 cact                  ! READ WRITE

      include 'files.fi'

      if (act .eq. 82) then             ! READ(LETR)
          cact = 'READ'
      else if (act .eq. 87) then        ! WRITE(LETW)
          cact = 'WRITE'
      else if (act .eq. 66) then        ! READWRITE(LETB)
          cact = 'READWRITE'
      else                              ! error
           uid = -1                     ! ERR(-1)
           fopen = -1                   ! ERR(-1)
           return
      end if

      call is2cs(fn,cfn,81)             ! MAXNAME(81) convert integer string to character string

      i = 1
      while (i .le. 20) do              ! MAXFIELS(20)
          if (finuse(i) .eq. 0) then    ! NOUSE(0)
              open(unit=i, file=cfn, action=cact, err=99)
              finuse(i) = 1             ! INUSE(1)
              uid = i
              fopen = i
              if (act .eq. 82) then     ! READ(LETR)
                  flastcr(i) = 80 + 1    ! MAXCARD(80)
                  fbuf(i,81) = 10       ! MAXLINE(81) NEWLINE(10)
                  fnew(i) = 0           ! NO(0)
                  fmode(i) = act        ! READ(LETR)
              else if (act .eq. 87) then ! WRITE(LETW)
                  flastcw(i) = 0
                  fmode(i) = act        ! WRITE(LETW)
              else if (act .eq. 66) then ! READWRITE(LETB)
                  flastcr(i) = 80 + 1    ! MAXCARD(80)
                  flastcw(i) = 0
                  fbuf(i,81) = 10       ! MAXLINE(81) NEWLINE(10)
                  fnew(i) = 0           ! NO(0)
                  fmode(i) = act        ! READWRITE(LETB)
              end if
              return
          endif
          i = i + 1
      end while
      
   99 continue
      uid = -1                          ! ERR(-1)
      fopen = -1                        ! ERR(-1)
      return
      end

flastcr,flastcwの初期設定と、READWRITEでファイルを開けた時の処理を追加しています。

fgetc()を次に示します。

c fgetc.for -- (extended version) get character from unit u
      integer*1 function fgetc(u,c)
      integer u
      integer*1 c
      integer i

      include 'files.fi'

      flastcr(u) = flastcr(u) + 1
      if ((flastcr(u) .gt. 81) .or. (fnew(u) .eq. 1)) then ! MAXCARD(80) YES(1)
          read(u,10,end=9) (fbuf(u,i),i=1,80) ! MAXCARD(80)
   10     format(80a1)                  ! MAXCARD(80)
          flastcr(u) = 1
          fnew(u) = 0                   ! NO(0)
          i = 80                        ! MAXCARD(80)
          while (fbuf(u,i) .eq. 32) do  ! BALNK(32)
              i = i - 1
          end while
          fbuf(u,i + 1) = 10            ! NEWLINE(10)
      endif
      c = fbuf(u,flastcr(u))
      fgetc = fbuf(u,flastcr(u))
      if (c .eq. 10) then               ! NEWLINE(10)
          fnew(u) = 1                   ! YES(1)
      end if
      return
    9 continue
      c = -1                            ! EOF(-1)
      fgetc = -1                        ! EOF(-1)
      return
      end

fnewを使て、行末を超えたことを判断するロジックを追加しています。

fputc()は、以下の通りです。