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

Ratforで書かれたプログラムからtokenを切り出すのは、defineやmacroと同様であるが、 引用符の通り扱いに注意が必要である。引用符は、ほとんどの場合ペアで使われ、その間に NEWLINEが入ることはない。この点に配慮する必要がある。

Ratofor版は以下の通り。

# gtoken.f -- get token for ratfor
      include ratfor.def
      character function gtoken(lexstr,toksiz)
      integer toksiz
      character lexstr(toksiz)
      character ngetc,type
      integer i
      character c

      include cline.ri

      while (ngetc(c) != EOF)
          if ((c != BLANK) & (c != TAB))
              break
      call putbak(c)
      for(i = 1;i < toksiz-1;i = i +1) {
          gtoken = type(ngetc(lexstr(i)))
          if ((gtoken != LETTER) & (gtoken != DIGIT))
              break
          }
      if (i >= toksiz-1)
          call synerr('token too long.')
      if (i > 1)
          call putbak(lexstr(i))
          lexstr(i) = EOS
          gtoken = ALPHA
      else if ((lexstr(1) == SQUOTE) | (lexstr(1) == DQUOTE))
          for (i = 2;ngetc(lexstr(i)) != lexstr(1)) {
              if (lexstr(i) == NEWLINE) {
                  call synerr('missing quote.')
                  lexstr(i) = lexstr(1)
                  call putbak(NEWLINE)
                  break
                  }
              }
      else if (lexstr(1) == SHARP) { # strip comments
          while (ngetc(lexstr(1)) != NEWLINE)
              ;
          gtoken = NEWLINE
          }
      lexstr(i+1) = EOS
      if (lexstr(1) == NEWLINE)
          linect = linect + 1
      return
      end

WATCOM Fortran77版は以下の通り。

c gtoken.f -- get token for ratfor
      include ratfor.def
      integer*1 function gtoken(lexstr,toksiz)
      integer toksiz
      integer*1 lexstr(toksiz)
      integer*1 ngetc,type
      integer i
      integer*1 c

      include cline.fi

      while (ngetc(c) .ne. EOF) do
          if ((c .ne. BLANK) .and. (c .ne. TAB)) then
              exit
          end if
      end while
      call putbak(c)
      i = 1
      while (i .lt. toksiz-1) do
          gtoken = type(ngetc(lexstr(i)))
          if ((gtoken .ne. LETTER) .and. (gtoken .ne. DIGIT)) then
              exit
          end if
          i = i + 1
      end while
      if (i .ge. toksiz-1) then
          call synerr('token too long.')
      end if
      if (i .gt. 1) then
          call putbak(lexstr(i))
          lexstr(i) = EOS
          gtoken = ALPHA
      else if (lexstr(1) .eq. SQUOTE .or. lexstr(1) .eq. DQUOTE) then
          i = 2
          while (ngetc(lexstr(i)) .ne. lexstr(1)) do
              if (lexstr(i) .eq. NEWLINE) then
                  call synerr('missing quote.')
                  lexstr(i) = lexstr(1)
                  call putbak(NEWLINE)
                  exit
              end if
              i = i + 1
          end while
      else if (lexstr(1) .eq. SHARP) then ! strip comments
          while (ngetc(lexstr(1)) .ne. NEWLINE) do
              ! nothing to do
          end while
          gtoken = NEWLINE
      end if
      lexstr(i+1) = EOS
      if (lexstr(1) .eq. NEWLINE) then
          linect = linect + 1
      end if
      return
      end

gtoken()の下請けルーチンsynerr()はsyntax errorを出力する。errorは、行番号とともに出力されるが、 行番号linectは、必要なモジュールで共有できるように、共通領域clineにおいている。

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

# synerr -- report Ratfor syntax error
      include ratfor.def
      subroutine synerr(msg)
      character msg(MAXLINE)
      character lc(MAXLINE)
      integer itoc
      integer junk

      include cline.ri

      call remark('error at line.')
      junk = itoc(linect,lc,MAXLINE)
      call putlin(lc,ERROUT)
      call fputc(ERROUT,COLON)
      call remark(msg)
      return
      end

WATCOM Fortran77版は以下の通り。

c synerr -- report Ratfor syntax error
      include ratfor.def
      subroutine synerr(msg)
      character msg(MAXLINE)
      integer*1 lc(MAXLINE)
      integer itoc
      integer junk

      include cline.fi

      call remark('error at line.')
      junk = itoc(linect,lc,MAXLINE)
      call putlin(lc,ERROUT)
      call fputc(ERROUT,BLANK)
      call remark(msg)
      return
      end

clineのRatofor版は以下の通り。

# cline.ri
      common /cline/linect
      integer linect
      data linect/1/

WATCOM Fortran77版は以下の通り。

c cline.fi
      common /cline/linect
      integer linect
      data linect/1/

gtoken()で切り出されたtokenは、次のlex()に引き継がれ解析される。 ここでも字句の判定に、lookup()を使用する。

lex()のRatfor版は以下の通り。

# lex.r4- return lexical type of token
      include ratfor.def
      character function lex(lexstr)
      character lexstr(MAXTOK)
      character gtoken
      integer alldig,lookup
      character ltype(2)

      while (gtoken(lexstr,MAXTOK) == NEWLINE)
          ;
      lex = lexstr(1)
      if (lex == EOF | lex == SEMICOL | lex == LBRACE | lex == RBRACE))
          return
      if (alldig(lexstr)==YES)
          lex = LEXDIGITS
      else if(lookup(lexstr,ltype) == YES)
          lex = ltype(1)
      else
          lex = LEXOTHER
      return
      end

WATCOM Fortran77版は以下の通り。

c lex.f- return lexical type of token
      include ratfor.def
      integer function lex(lexstr)
      integer*1 lexstr(MAXTOK)
      integer*1 gtoken
      integer alldig,lookup
      integer*1 ltype(2)

      while (gtoken(lexstr,MAXTOK) .eq. NEWLINE) do
          ! nothing to do
      end while
      lex = lexstr(1)
      if ((lex .eq. EOF) .or. (lex .eq. SEMICOL) .or.
     1    (lex .eq. LBRACE) .or. (lex .eq. RBRACE)) then
          return
      end if
      if (alldig(lexstr)) then
          lex = LEXDIGITS
      else if(lookup(lexstr,ltype) .eq. YES) then
          lex = ltype(1)
      else
          lex = LEXOTHER
      end if
      return
      end

lex()の下請けルーチンalldig()は、tokenが数字列か否かを判定する。

alldig()のRatfor版は以下の通り。

# alldig.r4 -- return YES if str is all digis
      include ratfor.def
      integer function alldig(s)
      character s(ARB)
      character type
      character i

      alldig = NO
      if (s(1) == EOS)
          return
      for (i = 1; s(i) != EOS; i = i +1)
          if (type(s(i)) != DIGIT)
              return
      alldig = YES
      return
      end

WATCOM Fortran77版は以下の通り。

c alldig -- return YES if str is all digis
      include ratfor.def
      integer function alldig(s)
      integer*1 s(ARB)
      integer*1 type
      integer i

      alldig = NO
      if (s(1) .eq. EOS) then
          return
      end if
      i = 1
      while (s(i) .ne. EOS) do
          if (type(s(i)) .ne. DIGIT) then
              return
          end if
          i = i + 1
      end while
      alldig = YES
      return
      end