アナクロなコンピューターエンジニアのつぶやき

stringは、文字列定数を格納するinteger*1型の配列を生成する部分と、 配列に文字を割り当てるdata文を生成する部分があるます。配列の大きさは、 格納する文字列の長さとEOSを格納する分が必要です。

          string name "data"

          integer*1 name(5)
          data name(1)/100/
          data name(2)/97/
          data name(3)/116/
          data name(4)/97/
          data name(5)/-2/
          

          string specs "!#$%&'( )=-"

      integer*1 specs(12)
      data specs(1)/33/
      data specs(2)/35/
      data specs(3)/36/
      data specs(4)/37/
      data specs(5)/38/
      data specs(6)/39/
      data specs(7)/40/
      data specs(8)/32/
      data specs(9)/41/
      data specs(10)/61/
      data specs(11)/45/
      data specs(12)/-2/

          string str1 'ab"cd'

      integer*1 str1(6)
      data str1(1)/97/
      data str1(2)/98/
      data str1(3)/34/
      data str1(4)/99/
      data str1(5)/100/
      data str1(6)/-2/

strngc()のRatofor版は以下の通り。

# strngc.r4 -- generate string data
      include ratfor.def
      subroutine strngc
      character ngetc,name(MAXTOK),strng(MAXLINE)
      integer c,i,l,length,n
      string intstr "integer*1 "
      string datstr "data "

      junk = lex(name)
      for (strng(1) = ngetc(strng(1)); strng(1) == BLANK); strng(1) = ngetc(strng(1))
          ;
      if (strng(1) != DQUOTE & strng(1) != SQUOTE)
          call synerr('missing quort.')
      i = 2
      for (strng(i) = ngetc(strng(i)); strng(1) != strng(i)); strng(i) = ngetc(strng(i)) {
           if (i >= MAXLINE) {
               call synerr('string data too long.')
               break
               }
           else if (strng(i) == NEWLINE) {
               call synerr('Unexpected NEWLINE.')
               break
               }
           else if (strng(i) == EOF) {
               call synerr('Unexpected EOF.')
               exit
               }
           i = i + 1
           }
      if (i >= MAXLINE)
          strng(MAXLINE) = EOS
      else
          strng(i+1) = EOS
      l = length(strng)
      call outtab
      call outstr(intstr)
      call outstr(name)
      call outch(LPAREN)
      call outnum(l-1)
      call outch(RPAREN)
      call outdon
      i = 1
      for (c = 2; c < l; c = c + 1) {
          call outtab
          call outstr(datstr)
          call outstr(name)
          call outch(LPAREN)
          call outnum(i)
          call outch(RPAREN)
          call outch(SLASH)
          n = strng(c)
          call outnum(n)
          call outch(SLASH)
          call outdon
          i = i + 1
          }
      call outtab
      call outstr(datstr)
      call outstr(name)
      call outch(LPAREN)
      call outnum(i)
      call outch(RPAREN)
      call outch(SLASH)
      call outnum(EOS)
      call outch(SLASH)
      call outdon
      return
      end

WATCOM Fortran77版は以下の通り。

c strngc.f -- generate string data
      include ratfor.def
      subroutine strngc
      integer*1 ngetc,name(MAXTOK),strng(MAXLINE)
      integer c,i,l,length,n
      integer*1 intstr(11)
      data intstr(1)/LETi/
      data intstr(2)/LETn/
      data intstr(3)/LETt/
      data intstr(4)/LETe/
      data intstr(5)/LETg/
      data intstr(6)/LETe/
      data intstr(7)/LETr/
      data intstr(8)/STAR/
      data intstr(9)/LET1/
      data intstr(10)/BLANK/
      data intstr(11)/EOS/
      integer*1 datstr(6)
      data datstr(1)/LETd/
      data datstr(2)/LETa/
      data datstr(3)/LETt/
      data datstr(4)/LETa/
      data datstr(5)/BLANK/
      data datstr(6)/EOS/

      junk = lex(name)
      strng(1) = ngetc(strng(1))
      while (strng(1) .eq. BLANK) do
          strng(1) = ngetc(strng(1))
      end while
      if (strng(1) .ne. DQUOTE .and. strng(1) .ne. SQUOTE) then
          call synerr('missing quort.')
      end if
      i = 2
      strng(i) = ngetc(strng(i))
      while (strng(1) .ne. strng(i)) do
           if (i .ge. MAXLINE) then
               call synerr('string data too long.')
               exit
           else if (strng(i) .eq. NEWLINE) then
               call synerr('Unexpected NEWLINE.')
               exit
           else if (strng(i) .eq. EOF) then
               call synerr('Unexpected EOF.')
               exit
           end if
           i = i + 1
           strng(i) = ngetc(strng(i))
      end while
      if (i .ge. MAXLINE) then
          strng(MAXLINE) = EOS
      else
          strng(i+1) = EOS
      end if
      l = length(strng)
      call outtab
      call outstr(intstr)
      call outstr(name)
      call outch(LPAREN)
      call outnum(l-1)
      call outch(RPAREN)
      call outdon
      i = 1
      c = 2
      while (c .lt. l) do
          call outtab
          call outstr(datstr)
          call outstr(name)
          call outch(LPAREN)
          call outnum(i)
          call outch(RPAREN)
          call outch(SLASH)
          n = strng(c)
          call outnum(n)
          call outch(SLASH)
          call outdon
          i = i + 1
          c = c + 1
      end while
      call outtab
      call outstr(datstr)
      call outstr(name)
      call outch(LPAREN)
      call outnum(i)
      call outch(RPAREN)
      call outch(SLASH)
      call outnum(EOS)
      call outch(SLASH)
      call outdon
      return
      end

これで、Ratforプリプロセッサの作成は完了しました。Ratforも含めた、展開処理用の バッチプログラムを以下に示します。

          @echo off
          rem fimr.bat
          cd ..\src
          ..\exe\include < %1.f | ..\exe\macro | ..\exe\ratfor > %1.for
          cd ..\bat

ソフトウェア作法に記載されている、RatforコードをWATCOM-fortran77に ポーティングする作業は、ひとまず終わりとします。ただし、実際にポーティングの課程 で作成したコードは、そのままの状態で、完成したRatforに通すことは、 できません。ratfor.defファイルのインクルードが必要なこととなど、 まだまだ、手を加える部分があります。これについては、次回から、必要な部分を取り出して、 説明します。

ファイル入出力に関する共通領域の初期化は、initfile()で行っていましたが、 これをdata文で静的に初期化することとします。

Ratofr版のfiles.riは以下の通りです。

# files.ri -- file interface common valiables
      common /files/finuse,fbuf,flastcr,flastcw,fmode,fnew
      integer finuse(MAXFILES)          # inuse flag
      character fbuf(MAXFILES,MAXLINE)  # I/O buffer
      integer flastcr(MAXFILES)         # characters in read buffer
      integer flastcw(MAXFILES)         # characters in write buffer
      character fmode(MAXFILES)         # READ/WIRTE flag
      integer fnew(MAXFILES)            # NEWLINE flag
      data finuse/MAXFILES*NOUSE/
      data flastcr/MAXFILES*0/
      data flastcw/MAXFILES*MAXLINE/
      data fmode/MAXFILES*READ/
      data fnew/MAXFILES*NO/
      data finuse(STDIN)/INUSE/
      data flastcr(STDIN)/MAXLINE/
      data fmode(STDIN)/READ/
      data finuse(STDOUT)/INUSE/
      data flastcw(STDOUT)/0/
      data fmode(STDOUT)/WRITE/

WATCOM fotran77版のfiles.fiは以下の通りです。

c files.fi -- file interface common valiables
      common /files/finuse,fbuf,flastcr,flastcw,fmode,fnew
      integer finuse(MAXFILES)          ! inuse flag
      integer*1 fbuf(MAXFILES,MAXLINE)  ! I/O buffer
      integer flastcr(MAXFILES)         ! characters in read buffer
      integer flastcw(MAXFILES)         ! characters in write buffer
      integer*1 fmode(MAXFILES)         ! READ/WIRTE flag
      integer fnew(MAXFILES)            ! NEWLINE flag
      data finuse/MAXFILES*NOUSE/
      data flastcr/MAXFILES*0/
      data flastcw/MAXFILES*MAXLINE/
      data fmode/MAXFILES*READ/
      data fnew/MAXFILES*NO/
      data finuse(STDIN)/INUSE/
      data flastcr(STDIN)/MAXLINE/
      data fmode(STDIN)/READ/
      data finuse(STDOUT)/INUSE/
      data flastcw(STDOUT)/0/
      data fmode(STDOUT)/WRITE/

files.ri、files.fiの変更により再コンパイルが必要になるファイルは、以下の通りです。

          fopen.for
          fclose.for
          fgetc.for
          fputc.for

これらは、macroが動き出す前のファイルですので、macroを使用する版を再掲します。

fopen()のRatofor版は以下の通りです。

# fopen.r4 -- connect internal file descripter and external file
      include ratfor.def
      integer function fopen(uid, fn, act)
      integer uid
      character fn(ARB), act
      integer i
      character*MAXLINE cfn
      character*9 cact  # for 'READ'/'WRITE'/'READWRITE'
      include files.fi

      if (act == READ)
          cact = 'READ'
      else if (act == WRITE)
          cact = 'WRITE'
      else if (act == READWRITE)
          cact = 'READWRITE'
      else {             # error
           uid = ERR
           fopen = ERR
           return
           }
      end if
      call is2cs(fn,cfn,MAXNAME)
      for (i = 1; i <= MAXFILES; i = i + 1)
          if (finuse(i) == NOUSE) {
              open(unit=i, file=cfn, action=cact, err=99)
              finuse(i) = INUSE
              uid = i
              fopen = i
              if (act == READ) {
                  flastcr(i) = MAXLINE
                  fbuf(i,MAXLINE) = NEWLINE
                  fnew(i) = NO
                  fmode(i) = act
                  }
              else if (act .eq. WRITE) {
                  flastcw(i) = 0
                  fmode(i) = act
                  }
              else if (act .eq. READWIRTE) {
                  flastcr(i) = MAXLINE
                  flastcw(i) = 0
                  fbuf(i,MAXLINE) = NEWLINE
                  fnew(i) = NO
                  fmode(i) = act
                  }
              return
              }
   99 continue
      uid = ERR
      fopen = ERR
      return
      end

fopen()のWATCOM fortran77版は以下の通りです。

c fopen.f -- connect internal file descripter and external file
      include ratfor.def
      integer function fopen(uid, fn, act)
      integer uid
      integer*1 fn(ARB), act
      integer i
      character*MAXLINE cfn
      character*9 cact                  ! READ WRITE
      include files.fi

      if (act .eq. READ) then
          cact = 'READ'
      else if (act .eq. WRITE) then
          cact = 'WRITE'
      else if (act .eq. READWRITE) then
          cact = 'READWRITE'
      else                              ! error
           uid = ERR
           fopen = ERR
           return
      end if
      call is2cs(fn,cfn,MAXNAME)
      i = 1
      while (i .le. MAXFILES) do
          if (finuse(i) .eq. NOUSE) then
              open(unit=i, file=cfn, action=cact, err=99)
              finuse(i) = INUSE
              uid = i
              fopen = i
              if (act .eq. READ) then
                  flastcr(i) = MAXLINE
                  fbuf(i,MAXLINE) = NEWLINE
                  fnew(i) = NO
                  fmode(i) = act
              else if (act .eq. WRITE) then
                  flastcw(i) = 0
                  fmode(i) = act
              else if (act .eq. READWIRTE) then
                  flastcr(i) = MAXLINE
                  flastcw(i) = 0
                  fbuf(i,MAXLINE) = NEWLINE
                  fnew(i) = NO
                  fmode(i) = act
              end if
              return
          endif
          i = i + 1
      end while
   99 continue
      uid = ERR
      fopen = ERR
      return
      end

fclose()のRatofor版は以下の通りです。

# fclose.r4 -- disconnect internal filedescripter and extenal file
      include ratfor.def
      subroutine fclose(uid)
      integer uid
      include files.fi

      if (!(uid == STDIN) | (uid == STDOUT))) then
          if (fmode(uid) == WRITE) then
              call fputc(uid,EOF)        ! flush buffer
          end if
          close(unit=uid, status='keep')
          finuse(uid) = NOUSE
          uid = 0
      end if
      return
      end

fclose()のWATCOM fortran77版は以下の通りです。

c fclose.f-- disconnect internal filedescripter and extenal file
      include ratfor.def
      subroutine fclose(uid)
      integer uid
      include files.fi

      if (.not. ((uid .eq. STDIN) .or. (uid .eq. STDOUT))) then
          if (fmode(uid) .eq. WRITE) then
              call fputc(uid,EOF)        ! flush buffer
          end if
          close(unit=uid, status='keep')
          finuse(uid) = NOUSE
          uid = 0
      end if
      return
      end

fgetc()のRatofor版は以下の通りです。

c fgetc.f -- (extended version) get character from unit u
# fgetc.r4 -- (extended version) get character from unit u
      include ratfor.def
      character function fgetc(u,c)
      integer u
      character c
      integer i
      include files.fi

      flastcr(u) = flastcr(u) + 1
      if ((flastcr(u) > MAXLINE) | (fnew(u) == YES)) {
          read(u,10,end=9) (fbuf(u,i),i=1,MAXCARD)
   10     format(MAXCARD a1)
          flastcr(u) = 1
          fnew(u) = NO
          for (i = MAXCARD; (fbuf(u,i) == BLANK); i = i - 1)
              ;
          fbuf(u,i + 1) = NEWLINE
          }
      c = fbuf(u,flastcr(u))
      fgetc = fbuf(u,flastcr(u))
      if (c == NEWLINE)
          fnew(u) = YES
      return
    9 continue
      c = EOF
      fgetc = EOF
      return
      end

fgetc()のWATCOM fortran77版は以下の通りです。

c fgetc.f -- (extended version) get character from unit u
      include ratfor.def
      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. MAXLINE) .or. (fnew(u) .eq. YES)) then
          read(u,10,end=9) (fbuf(u,i),i=1,MAXCARD)
   10     format(MAXCARD a1)
          flastcr(u) = 1
          fnew(u) = NO
          i = MAXCARD
          while (fbuf(u,i) .eq. BLANK) do
              i = i - 1
          end while
          fbuf(u,i + 1) = NEWLINE
      endif
      c = fbuf(u,flastcr(u))
      fgetc = fbuf(u,flastcr(u))
      if (c .eq. NEWLINE) then
          fnew(u) = YES
      end if
      return
    9 continue
      c = EOF
      fgetc = EOF
      return
      end

fclose()のRatofor版は以下の通りです。

# fputc.r4 (extended version) -- put character on file
      include ratfor.def
      subroutine fputc(u,c)
      integer i,u
      character c
      include files.fi

      if ((c == EOF) & (flastcw(u) == 0))
          return                        ! buffer is empty, nothing to do
      if (flastcw(u) >= MAXCARD | c == NEWLINE | c == EOF) {
          write(u,10) (fbuf(u,i),i=1,flastcw(u))
   10     format(MAXCARD a1)
          flastcw(u) = 0
          }
      if (c != NEWLINE) {
          flastcw(u) = flastcw(u) + 1
          fbuf(u,flastcw(u)) = c
          }
      return
      end

fclose()のWATCOM fortran77版は以下の通りです。

c fputc.f (extended version) -- put character on file
      include ratfor.def
      subroutine fputc(u,c)
      integer i,u
      integer*1 c
      include files.fi

      if ((c .eq. EOF) .and. (flastcw(u) .eq. 0)) then
          return                        ! buffer is empty, nothing to do
      end if
      if (flastcw(u) .ge. MAXCARD .or. c .eq. NEWLINE .or. c .eq. EOF) then
          write(u,10) (fbuf(u,i),i=1,flastcw(u))
   10     format(MAXCARD a1)
          flastcw(u) = 0
      end if
      if (c .ne. NEWLINE) then
          flastcw(u) = flastcw(u) + 1
          fbuf(u,flastcw(u)) = c
      end if
      return
      end

また、initfile()が不要になることで修正・再コンパイルが必要になるファイルは、 以下の通りです。

          archive.for
          change.for
          compare2.for
          concat.for
          copy.for
          copyfile.for
          define.f
          edit.f
          find.for
          include.for
          macro.f
          makecopy.for
          ratfor.f
          sort.for
          typex.for
          unique.for
          xformat.f
          xprint.for

実際の変更点については割愛します。