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

完成した"macro"を使ってみて、以下の不具合が見つかった。

1. マクロの外で、'や"で囲まれた文字列(たいていの場合文字列定数)に含まれるマクロ名も置換されてしまう。
2. マクロ"string"は、英数字しか展開できない。
3. マクロ"string"の下請けマクロ"len","str"が、プログラム中の変数とぶつかる可能性が多々ある。

このうち2に関しては、Ratforプリプロセッサーに組み込むこととし、 1は、macroのメインルーチンを手直しして対応し、3は、マクロ名を手直しして対応する。

macroの、メインルーチンの修正点は、マクロの外を処理している最中に "や'が出現したら、対応する"や'が出現するまで読み込み、出力する。ただし、 対応する"や'が出現しない場合は、先頭の"だけを出力する。

RATFOR版は、以下の通り。

# macro.r4 -- expand macros with arguments
      program macro
      character gettok
      character defn(MAXDEF),t,token(MAXTOK)
      integer lookup,push
      integer ap,argstk(ARGSIZE),callst(CALLSIZE),i,nlb,plev(CALLSIZE)

      string balp "()"
      string defnam "define"
      character deftyp(2)
      data deftyp(1)/DEFTYPE/,deftyp(2)/EOS/
      string incnam "incr"
      character inctype(2)
      data inctyp(1)/INCTYPE/,inctyp(2)/EOS/
      string subnam "substr"
      character subtype(2)
      data subtyp(1)/SUBTYPE/,subtyp(2)/EOS/
      string ifnam "ifelse"
      character iftype(2)
      data iftyp(1)/IFTYPE/,iftyp(2)/EOS/
      string udfnam "ifelse"
      character udftype(2)
      data udftyp(1)/UDFTYPE/,udftyp(2)/EOS/
      string ifdnam "ifdef"
      character ifdtype(2)
      data ifdtyp(1)/IFDTYPE/,ifdtyp(2)/EOS/

      include cmacro.fi

      call initfile
      call inittbl
      call initbuf
      call instal(defnam,deftyp)
      call instal(incnam,inctyp)
      call instal(subnam,subtyp)
      call instal(ifnam,iftyp)
      call instal(udfnam,udftyp)
      call instal(ifdnam,ifdtyp)
      cp = 0
      ap = 1
      ep = 1
      for (t = gettok(token,MAXTOK); t !=  EOF; t = gettok(token,MAXTOK)) {
          if (t == ALPHA) {
              if (lookup(token,defn) == NO)
                  call puttok(token)
              else {                    # defined; put it in eval stack
                  cp = cp + 1
                  if (cp > CALLSIZE) then
                      call error('call stack overflow.')
                  callst(cp) = ap
                  ap = push(ep,argstk,ap)
                  call puttok(defn)     # stack definition
                  call putchr(EOS)
                  ap = push(ep,argstk,ap)
                  call puttok(token)    # stack name
                  call putchr(EOS)
                  ap = push(ep,argstk,ap)
                  t = gettok(token,MAXTOK) # peek at next
                  call pbstr(token)
                  if (t != LPAREN)      # add ( ) if not present
                      call pbstr(balp)
                  plev(cp) = 0
                  }
              }
          else if (t == LBRACK) {       # strip one level of [ ]
              nlb = 1
              repeat {
                  t = gettok(token,MAXTOK)
                  if (t == LBRACK)
                      nlb = nlb + 1
                  else if (t == RBRACK) {
                      nlb = nlb - 1
                      if (nlb == 0)
                          break
                      }
                  else if (t == EOF)
                      call error('EOF in string.')
                  call puttok(token)
                  }
          else if (cp == 0) {           # not in a macro at all
              if (token(1) == SQUOTE ! token(1) == DQUOTE) {
                  for (i = 2; ngetc(token(i)) != token(1); i = i + 1) {
                      if (token(i) == NEWLINE) {
                          token(i+1) = EOS
                          call pbstr(token(2))
                          i = 1
                          break
                          }
                      }
                  token(i+1) = EOS
                  }
              call puttok(token)
              }
          else if (t == LPAREN)
              if (plev(cp) > 0)
                  call puttok(token)
              plev(cp) = plev(cp) + 1
          else if (t == RPAREN) {
              plev(cp) = plev(cp) - 1
              if (plev(cp) .gt. 0)
                  call puttok(token)
              else {                    # end of argument list
                  call putchr(EOS)
                  call eval(argstk,callst(cp),ap-1)
                  ap = callst(cp)       # pop eval stack
                  ep = argstk(ap)
                  cp = cp - 1
                  }
          else if ((t == COMMA) $ (plev(cp) == 1)) {
              call putchr(EOS)
              ap = push(ep,argstk,ap)
              }
          else
              call puttok(token)
          }
      if (cp != 0)
          call error('unexpected EOF.')
      stop
      end

WATCOM Fortran 77版は以下の通り。

c macro.f -- expand macros with arguments
      include ratfor.def
      program macro
      integer*1 gettok,ngetc
      integer*1 defn(MAXDEF),t,token(MAXTOK)
      integer lookup,push
      integer ap,argstk(ARGSIZE),callst(CALLSIZE),i,nlb,plev(CALLSIZE)

      integer*1 balp(3)
      data balp(1)/LPAREN/
      data balp(2)/RPAREN/
      data balp(3)/EOS/

      integer*1 defnam(7)
      data defnam(1)/LETd/
      data defnam(2)/LETe/
      data defnam(3)/LETf/
      data defnam(4)/LETi/
      data defnam(5)/LETn/
      data defnam(6)/LETe/
      data defnam(7)/EOS/
      integer*1 deftyp(2)
      data deftyp(1)/DEFTYPE/
      data deftyp(2)/EOS/

      integer*1 incnam(5)
      data incnam(1)/LETi/
      data incnam(2)/LETn/
      data incnam(3)/LETc/
      data incnam(4)/LETr/
      data incnam(5)/EOS/
      integer*1 inctyp(2)
      data inctyp(1)/INCTYPE/
      data inctyp(2)/EOS/

      integer*1 subnam(7)
      data subnam(1)/LETs/
      data subnam(2)/LETu/
      data subnam(3)/LETb/
      data subnam(4)/LETs/
      data subnam(5)/LETt/
      data subnam(6)/LETr/
      data subnam(7)/EOS/
      integer*1 subtyp(2)
      data subtyp(1)/SUBTYPE/
      data subtyp(2)/EOS/

      integer*1 ifnam(7)
      data ifnam(1)/LETi/
      data ifnam(2)/LETf/
      data ifnam(3)/LETe/
      data ifnam(4)/LETl/
      data ifnam(5)/LETs/
      data ifnam(6)/LETe/
      data ifnam(7)/EOS/
      integer*1 iftyp(2)
      data iftyp(1)/IFTYPE/
      data iftyp(2)/EOS/

      integer*1 udfnam(6)
      data udfnam(1)/LETu/
      data udfnam(2)/LETn/
      data udfnam(3)/LETd/
      data udfnam(4)/LETe/
      data udfnam(5)/LETf/
      data udfnam(6)/EOS/
      integer*1 udftyp(2)
      data udftyp(1)/UDFTYPE/
      data udftyp(2)/EOS/

      integer*1 ifdnam(6)
      data ifdnam(1)/LETi/
      data ifdnam(2)/LETf/
      data ifdnam(3)/LETd/
      data ifdnam(4)/LETe/
      data ifdnam(5)/LETf/
      data ifdnam(6)/EOS/
      integer*1 ifdtyp(2)
      data ifdtyp(1)/IFDTYPE/
      data ifdtyp(2)/EOS/

      include cmacro.fi

      call initfile
      call inittbl
      call initbuf
      call instal(defnam,deftyp)
      call instal(incnam,inctyp)
      call instal(subnam,subtyp)
      call instal(ifnam,iftyp)
      call instal(udfnam,udftyp)
      call instal(ifdnam,ifdtyp)
      cp = 0      ! current call stack pointer
      ap = 1      ! next free position in argstk
      ep = 1      ! next free position in evalst
      t = gettok(token,MAXTOK) 
      while (t .ne. EOF) do
          if (t .eq. ALPHA) then
              if (lookup(token,defn) .eq. NO) then
                  call puttok(token)
              else                          ! defined; put it in eval stack
                  cp = cp + 1
                  if (cp .gt. CALLSIZE) then
                      call error('call stack overflow.')
                  end if
                  callst(cp) = ap
                  ap = push(ep,argstk,ap)
                  call puttok(defn)         ! stack definition
                  call putchr(EOS)
                  ap = push(ep,argstk,ap)
                  call puttok(token)        ! stack name
                  call putchr(EOS)
                  ap = push(ep,argstk,ap)
                  t = gettok(token,MAXTOK)  ! peek at next
                  call pbstr(token)
                  if (t .ne. LPAREN) then   ! add ( ) if not present
                      call pbstr(balp)
                  end if
                  plev(cp) = 0
              end if
          else if (t .eq. LBRACK) then      ! strip one level of [ ]
              nlb = 1
              loop
                  t = gettok(token,MAXTOK)
                  if (t .eq. LBRACK) then
                      nlb = nlb + 1
                  else if (t .eq. RBRACK) then
                      nlb = nlb - 1
                      if (nlb .eq. 0) then
                          exit
                      end if
                  else if (t .eq. EOF) then
                      call error('EOF in string.')
                  end if
                  call puttok(token)
              end loop
          else if (cp .eq. 0) then          ! not in a macro at all
              if (token(1) .eq. SQUOTE .or. token(1) .eq. DQUOTE) then
                  i = 2
                  while (ngetc(token(i)) .ne. token(1)) do
                      if (token(i) .eq. NEWLINE) then
                          token(i+1) = EOS
                          call pbstr(token(2))
                          i = 1
                          exit
                      end if
                      i = i + 1
                  end while
                  token(i+1) = EOS
              end if
              call puttok(token)
          else if (t .eq. LPAREN) then
              if (plev(cp) .gt. 0) then
                  call puttok(token)
              end if
              plev(cp) = plev(cp) + 1
          else if (t .eq. RPAREN) then
              plev(cp) = plev(cp) - 1
              if (plev(cp) .gt. 0) then
                  call puttok(token)
              else                         ! end of argument list
                  call putchr(EOS)
                  call eval(argstk,callst(cp),ap-1)
                  ap = callst(cp)          ! pop eval stack
                  ep = argstk(ap)
                  cp = cp - 1
              end if
          else if ((t .eq. COMMA) .and. (plev(cp) .eq. 1)) then
              call putchr(EOS)
              ap = push(ep,argstk,ap)
          else
              call puttok(token)
          end if
          t = gettok(token,MAXTOK)
      end while

      if (cp .ne. 0) then
          call error('unexpected EOF.')
      end if

      stop
      end

マクロ"string"の下請けマクロ"len","str"は、以下のように変更した。

define(00length00,[ifelse($1,,0,[incr(00length00(substr($1,2)))])])
define(string,[integer*1 $1(00length00(substr($2,2)))
00string00($1,substr($2,2),0)
      data $1(00length00(substr($2,2)))/EOS/
])
define(00string00,[ifelse($2,",,      data $1(incr($3))/[LET]substr($2,1,1)/
[00string00($1,substr($2,2),incr($3))])])

組み込み関数"ifelse"の実装は以下の通り。

RATFOR版

# doif.f -- select one of two arguments
      include ratfor.def
      subroutine doif(argstk,i,j)
      integer i,j,argstk(ARGSIZE)
      integer equal
      integer a2,a3,a4,a5

      include cmacro.ri

      if (j-i < 5)
          return

      a2 = argstk(i + 2)
      a3 = argstk(i + 3)
      a4 = argstk(i + 4)
      a5 = argstk(i + 5)

      if (equal(evalst(a2),evalst(a3)) == YES)
          call pbstr(evalst(a4))
      else
          call pbstr(evalst(a5))
      return
      end

WATCOM Fortran 77版は以下の通り。

c doif.f -- select one of two arguments
      include ratfor.def
      subroutine doif(argstk,i,j)
      integer i,j,argstk(ARGSIZE)
      integer equal
      integer a2,a3,a4,a5

      include cmacro.fi

      if (j-i .lt. 5) then
          return
      end if

      a2 = argstk(i + 2)
      a3 = argstk(i + 3)
      a4 = argstk(i + 4)
      a5 = argstk(i + 5)

      if (equal(evalst(a2),evalst(a3)) .eq. YES) then
          call pbstr(evalst(a4))
      else
          call pbstr(evalst(a5))
      end if
      return
      end

組み込み関数"incr"は、引数を数値化して、下請けルーチンpbnum()で+1し、文字列化して入力に戻す。"incr"の実装は 以下の通り。

RATFOR版

# doinc.r4 -- increment argument by 1
      include ratfor.def
      subroutine doincr(argstk,i,j)
      integer i,j,argstk(ARGSIZE)
      integer ctoi
      integer k

      include cmacro.ri

      k = argstk(i+2)
      call pbnum(ctoi(evalst,k)+1)
      return
      end

WATCOM Fortran 77版は以下の通り。

c doinc.f -- increment argument by 1
      include ratfor.def
      subroutine doinc(argstk,i,j)
      integer i,j,argstk(ARGSIZE)
      integer ctoi
      integer k

      include cmacro.fi

      k = argstk(i+2)
      call pbnum(ctoi(evalst,k)+1)
      return
      end

下請けルーチンpbnum()は以下の通り。

RATFOR版は以下の通り。

# pbnum.r4 -- convert number to string, push back on input
      include ratfor.def
      subroutine pbnum(n)
      integer n
      integer mod
      integer m,num
      string digits "0123456789"

      num = n
      repeat {
          m = mod(num,10)
          call putbak(digits(m+1))
          num = num/10
          } until (num == 0)
      return
      end

WATCOM Fortran 77版は以下の通り。

c pbnum.f -- convert number to string, push back on input
      include ratfor.def
      subroutine pbnum(n)
      integer n
      integer mod
      integer m,num
      integer*1 digits(11)
      data digits(1)/LET0/
      data digits(2)/LET1/
      data digits(3)/LET2/
      data digits(4)/LET3/
      data digits(5)/LET4/
      data digits(6)/LET5/
      data digits(7)/LET6/
      data digits(8)/LET7/
      data digits(9)/LET8/
      data digits(10)/LET9/
      data digits(11)/EOS/

      num = n
      loop
          m = mod(num,10)
          call putbak(digits(m+1))
          num = num/10
      until (num .eq. 0)
      return
      end

組み込み関数"substr"の実装は、以下の通り。

RATFOR版は以下の通り。

# dosub.r4 -- select substring
      include ratfor.def
      subroutine dosub(argstk,i,j)
      integer i,j,argstk(ARGSIZE)
      integer ctoi,length,min
      integer ap,fc,k,nc

      include cmacro.ri

      if (j-i < 3)
          return
      if (j-i < 4)
          nc = MAXTOK
      else {
          k = argstk(i+4)
          nc = ctoi(evalst,k)           # number of characters
          }
      k = argstk(i+3)                   # origin
      ap = argstk(i+2)                  # target string
      fc = ap + ctoi(evalst,k) - 1      # first char of substring
      if ((fc >= ap) & (fc < ap+length(evalst(ap)))) { # subarrays
          k = fc + min(nc,length(evalst(fc))) - 1
          for ( ; k >= fc ; k = k -1)
              call putbak(evalst(k))
          }
      return
      end

WATCOM Fortran 77版は以下の通り。

c dosub.f -- select substring
      include ratfor.def
      subroutine dosub(argstk,i,j)
      integer i,j,argstk(ARGSIZE)
      integer ctoi,length,min
      integer ap,fc,k,nc

      include cmacro.fi

      if (j-i .lt. 3) then
          return
      end if
      if (j-i .lt. 4) then
          nc = MAXTOK
      else
          k = argstk(i+4)
          nc = ctoi(evalst,k)      ! number of characters
      end if
      k = argstk(i+3)              ! origin
      ap = argstk(i+2)             ! target string
      fc = ap + ctoi(evalst,k) - 1 ! first char of substring
      if ((fc .ge. ap) .and. (fc .lt. ap+length(evalst(ap)))) then ! subarrays
          k = fc + min(nc,length(evalst(fc))) - 1
          while (k .ge. fc) do
              call putbak(evalst(k))
              k = k - 1
          end while
      end if
      return
      end

組み込み関数"undef"の実装は、以下の通り。

RATFOR版

# doudf.f -- undefine macro
      include ratfor.def
      subroutine doudf(argstk,i,j)
      integer i,j,argstk(ARGSIZE)
      integer a2

      include cmacro.r4

      if (j-i .lt. 1)
          return

      a2 = argstk(i + 2)
      call uninst(evalst(a2))
      return
      end

WATCOM Fortran 77版は以下の通り。

c doudf.f -- undefine macro
      include ratfor.def
      subroutine doudf(argstk,i,j)
      integer i,j,argstk(ARGSIZE)
      integer a2

      include cmacro.fi

      if (j-i .lt. 1) then
          return
      end if

      a2 = argstk(i + 2)
      call uninst(evalst(a2))
      return
      end

組み込み関数"ifdef"の実装は、以下の通り。

RATFOR版

# doifd.r4 -- define if macro is defined
      include ratfor.def
      subroutine doifd(argstk,i,j)
      integer i,j,argstk(ARGSIZE)
      integer lookup
      integer a2,a3,a4
      character junk(MAXDEF)

      include cmacro.fi

      if (j-i .lt. 4)
          return

      a2 = argstk(i + 2)
      a3 = argstk(i + 3)
      a4 = argstk(i + 4)
      if (lookup(evalst(a2),junk) .eq. YES)
          call pbstr(evalst(a3))
      else
          call pbstr(evalst(a4))
      return
      end

WATCOM Fortran 77版は以下の通り。

# doifd.r4 -- define if macro is defined
      include ratfor.def
      subroutine doifd(argstk,i,j)
      integer i,j,argstk(ARGSIZE)
      integer lookup
      integer a2,a3,a4
      character junk(MAXDEF)

      include cmacro.fi

      if (j-i .lt. 4)
          return

      a2 = argstk(i + 2)
      a3 = argstk(i + 3)
      a4 = argstk(i + 4)
      if (lookup(evalst(a2),junk) .eq. YES)
          call pbstr(evalst(a3))
      else
          call pbstr(evalst(a4))
      return
      end

マクロの応用を紹介する。

文字列の長さを返す"len"。再帰的定義になっているが、込み入ってない。

          define(len,[ifelse($1,,0,[incr(len(substr($1,2)))])])

文字列を定義する"string"。

           string(name,"STRING")

とすると

           integer name(6)
           data name(1)/LETS/
           data name(2)/LETT/
           data name(3)/LETR/
           data name(4)/LETN/
           data name(5)/LETG/

           data name(6)/EOS/

と展開される。"string"の定義は、以下の通り。

          define(string,[integer $1(len(substr($2,2)))
          str($1,substr($2,2),0)
                data $1(len(substr($2,2)))/EOS/
          ])

下請けルーチンの"str"は、以下の通り。

          define(str,[ifelse($2,",,      data $1(incr($3))/[LET]substr($2,1,1)/
          [str($1,substr($2,2),incr($3))])])

macro.r4中の

      string(balp,"()")

マクロが動くようになったので、バッチファイル"fim.bat"を作成し、マクロの展開に 使用する。

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

ここで、いくつかの有用な組み込み関数を追加する。追加する組み込み関数は、以下の通り。

• ifelse(a,b,c,d) -- aとbが文字列として等しければ、cをそうでなければ、dを返す。
• incr(a) -- aに+1した値を返す。
• substr(a,b,c) -- 文字列aのb文字目から、c文字を返す。cがなければ、文字列の最後まで返す。
• undef(a) -- マクロaを削除する。
• ifdef(a,b,c) -- マクロaが定義されていれば、bをそうでなければ、cを返す。

簡単な例を以下に示す。

          define(EOF,-1)
          define(EOS,-2)
          define(MAXCARD,80)
          define(MAXLINE,[incr(MAXCARD)]) -- MAXLINEは81になる。
          define(FOO,0)
          define(STR1,ABCDE)
          define(STR2,12345)
          ifdef([BAR],STR1,STR2) -- BARは定義されていないので、"12345"が返る。
          ifdef([FOO],STR1,STR2) -- FOOは定義されているので、"ABCDE"が返る。
          substr(STR1,3,2) -- "CD"が返る。
          substr(STR2,3) -- "345"が返る。
          undef([FOO]) -- FOOを削除する。"[]"が必要である。
          define(compare,[ifelse($1,$2,YES,NO)]) -- 2つの引数が等しければ、YESを そうでなければNOを返すマクロ"compare"を定義する。

追加する組み込み関数のそれぞれの処理は、eval()の中で各処理ルーチンを呼び出す。新しいeval()は、以下の通り。

RATFOR版

# eval.r4 - expand args i through j: evaluate builtin or push back defn
      subroutine eval(argstk,i,j)
      integer i,j,argstk(ARGSIZE)
      integer iindex,length
      integer argno,k,m,n,t,td
      include cmacro.ri
      string digits "0123456789"

      t = argstk(i)
      td = evalst(t)
      if (td == DEFTYPE)
          call dodef(argstk,i,j)
      else if (td == INCTYPE)
          call doinc(argstk,i,j)
      else if (td == SUBTYPE)
          call dosub(argstk,i,j)
      else if (td == IFTYPE)
          call doif(argstk,i,j)
      else if (td == UDFTYPE)
          call doudf(argstk,i,j)
      else if (td == IFDTYPE) {
          call doifd(argstk,i,j)
          }
      else {
          for (k = t + length(evalst(t)) - 1; k > t); k = k - 1)
              if (evalst(k-1) != ARGFLAG)
                  call putbak(evalst(k))
              else {
                  argno = iindex(digits,evalst(k)) - 1
                  if (argno >= 0) {
                      n = i + argno + 1
                      m = argstk(n)
                      call pbstr(evalst(m))
                      }
                  k = k - 1     # skip over $
                  }
          if (k == t)           # do last character
              call putbak(evalst(k))
          }
      return
      end

WATCOM Fortran 77版は以下の通り。

c eval.f - expand args i through j: evaluate builtin or push back defn
      include ratfor.def
      subroutine eval(argstk,i,j)
      integer i,j,argstk(ARGSIZE)
      integer iindex,length
      integer argno,k,m,n,t,td,junk
      include cmacro.fi

      integer*1 digits(11)
      data digits(1)/LET0/
      data digits(2)/LET1/
      data digits(3)/LET2/
      data digits(4)/LET3/
      data digits(5)/LET4/
      data digits(6)/LET5/
      data digits(7)/LET6/
      data digits(8)/LET7/
      data digits(9)/LET8/
      data digits(10)/LET9/
      data digits(11)/EOS/

      t = argstk(i)
      td = evalst(t)
      if (td .eq. DEFTYPE) then
          call dodef(argstk,i,j)
      else if (td .eq. INCTYPE) then
          call doinc(argstk,i,j)
      else if (td .eq. SUBTYPE) then
          call dosub(argstk,i,j)
      else if (td .eq. IFTYPE) then
          call doif(argstk,i,j)
      else if (td .eq. UDFTYPE) then
          call doudf(argstk,i,j)
      else if (td .eq. IFDTYPE) then
          call doifd(argstk,i,j)
      else
          k = t + length(evalst(t)) - 1
          while (k .gt. t) do
              if (evalst(k-1) .ne. ARGFLAG) then
                  call putbak(evalst(k))
              else
                  argno = iindex(digits,evalst(k)) - 1
                  if (argno .ge. 0) then
                      n = i + argno + 1
                      m = argstk(n)
                      call pbstr(evalst(m))
                  end if
                  k = k - 1       ! skip over $
              end if
              k = k - 1
          end while
          if (k .eq. t) then
              call putbak(evalst(k))
          end if
      end if
      return
      end

メインルーチンmacroでは、追加した組み込み関数を登録する必要がある。

RATFOR版は以下の通り。

# macro.r4 -- expand macros with arguments
      program macro
      character gettok
      character defn(MAXDEF),t,token(MAXTOK)
      integer lookup,push
      integer ap,argstk(ARGSIZE),callst(CALLSIZE),nlb,plev(CALLSIZE)

      string balp "()"
      string defnam "define"
      character deftyp(2)
      data deftyp(1)/DEFTYPE/,deftyp(2)/EOS/
      string incnam "incr"
      character inctype(2)
      data inctyp(1)/INCTYPE/,inctyp(2)/EOS/
      string subnam "substr"
      character subtype(2)
      data subtyp(1)/SUBTYPE/,subtyp(2)/EOS/
      string ifnam "ifelse"
      character iftype(2)
      data iftyp(1)/IFTYPE/,iftyp(2)/EOS/
      string udfnam "ifelse"
      character udftype(2)
      data udftyp(1)/UDFTYPE/,udftyp(2)/EOS/
      string ifdnam "ifdef"
      character ifdtype(2)
      data ifdtyp(1)/IFDTYPE/,ifdtyp(2)/EOS/

      include cmacro.fi

      call initfile
      call inittbl
      call initbuf
      call instal(defnam,deftyp)
      call instal(incnam,inctyp)
      call instal(subnam,subtyp)
      call instal(ifnam,iftyp)
      call instal(udfnam,udftyp)
      call instal(ifdnam,ifdtyp)
      cp = 0
      ap = 1
      ep = 1
      for (t = gettok(token,MAXTOK); t !=  EOF; t = gettok(token,MAXTOK)) {
          if (t == ALPHA) {
              if (lookup(token,defn) == NO)
                  call puttok(token)
              else {                    # defined; put it in eval stack
                  cp = cp + 1
                  if (cp > CALLSIZE) then
                      call error('call stack overflow.')
                  callst(cp) = ap
                  ap = push(ep,argstk,ap)
                  call puttok(defn)     # stack definition
                  call putchr(EOS)
                  ap = push(ep,argstk,ap)
                  call puttok(token)    # stack name
                  call putchr(EOS)
                  ap = push(ep,argstk,ap)
                  t = gettok(token,MAXTOK) # peek at next
                  call pbstr(token)
                  if (t != LPAREN)      # add ( ) if not present
                      call pbstr(balp)
                  plev(cp) = 0
                  }
              }
          else if (t == LBRACK) {       # strip one level of [ ]
              nlb = 1
              repeat {
                  t = gettok(token,MAXTOK)
                  if (t == LBRACK)
                      nlb = nlb + 1
                  else if (t == RBRACK) {
                      nlb = nlb - 1
                      if (nlb == 0)
                          break
                      }
                  else if (t == EOF)
                      call error('EOF in string.')
                  call puttok(token)
                  }
          else if (cp == 0)             # not in a macro at all
              call puttok(token)
          else if (t == LPAREN)
              if (plev(cp) > 0)
                  call puttok(token)
              plev(cp) = plev(cp) + 1
          else if (t == RPAREN) {
              plev(cp) = plev(cp) - 1
              if (plev(cp) .gt. 0)
                  call puttok(token)
              else {                    # end of argument list
                  call putchr(EOS)
                  call eval(argstk,callst(cp),ap-1)
                  ap = callst(cp)       # pop eval stack
                  ep = argstk(ap)
                  cp = cp - 1
                  }
          else if ((t == COMMA) $ (plev(cp) == 1)) {
              call putchr(EOS)
              ap = push(ep,argstk,ap)
              }
          else
              call puttok(token)
          }
      if (cp != 0)
          call error('unexpected EOF.')
      stop
      end

WATCOM Fortran 77版は以下の通り。

c macro.f -- expand macros with arguments
      include ratfor.def
      program macro
      integer*1 gettok
      integer*1 defn(MAXDEF),t,token(MAXTOK)
      integer lookup,push
      integer ap,argstk(ARGSIZE),callst(CALLSIZE),nlb,plev(CALLSIZE)

      integer*1 balp(3)
      data balp(1)/LPAREN/
      data balp(2)/RPAREN/
      data balp(3)/EOS/

      integer*1 defnam(7)
      data defnam(1)/LETd/
      data defnam(2)/LETe/
      data defnam(3)/LETf/
      data defnam(4)/LETi/
      data defnam(5)/LETn/
      data defnam(6)/LETe/
      data defnam(7)/EOS/
      integer*1 deftyp(2)
      data deftyp(1)/DEFTYPE/
      data deftyp(2)/EOS/

      integer*1 incnam(5)
      data incnam(1)/LETi/
      data incnam(2)/LETn/
      data incnam(3)/LETc/
      data incnam(4)/LETr/
      data incnam(5)/EOS/
      integer*1 inctyp(2)
      data inctyp(1)/INCTYPE/
      data inctyp(2)/EOS/

      integer*1 subnam(7)
      data subnam(1)/LETs/
      data subnam(2)/LETu/
      data subnam(3)/LETb/
      data subnam(4)/LETs/
      data subnam(5)/LETt/
      data subnam(6)/LETr/
      data subnam(7)/EOS/
      integer*1 subtyp(2)
      data subtyp(1)/SUBTYPE/
      data subtyp(2)/EOS/

      integer*1 ifnam(7)
      data ifnam(1)/LETi/
      data ifnam(2)/LETf/
      data ifnam(3)/LETe/
      data ifnam(4)/LETl/
      data ifnam(5)/LETs/
      data ifnam(6)/LETe/
      data ifnam(7)/EOS/
      integer*1 iftyp(2)
      data iftyp(1)/IFTYPE/
      data iftyp(2)/EOS/

      integer*1 udfnam(6)
      data udfnam(1)/LETu/
      data udfnam(2)/LETn/
      data udfnam(3)/LETd/
      data udfnam(4)/LETe/
      data udfnam(5)/LETf/
      data udfnam(6)/EOS/
      integer*1 udftyp(2)
      data udftyp(1)/UDFTYPE/
      data udftyp(2)/EOS/

      integer*1 ifdnam(6)
      data ifdnam(1)/LETi/
      data ifdnam(2)/LETf/
      data ifdnam(3)/LETd/
      data ifdnam(4)/LETe/
      data ifdnam(5)/LETf/
      data ifdnam(6)/EOS/
      integer*1 ifdtyp(2)
      data ifdtyp(1)/IFDTYPE/
      data ifdtyp(2)/EOS/

      include cmacro.fi

      call initfile
      call inittbl
      call initbuf
      call instal(defnam,deftyp)
      call instal(incnam,inctyp)
      call instal(subnam,subtyp)
      call instal(ifnam,iftyp)
      call instal(udfnam,udftyp)
      call instal(ifdnam,ifdtyp)
      cp = 0      ! current call stack pointer
      ap = 1      ! next free position in argstk
      ep = 1      ! next free position in evalst
      t = gettok(token,MAXTOK) 
      while (t .ne. EOF) do
          if (t .eq. ALPHA) then
              if (lookup(token,defn) .eq. NO) then
                  call puttok(token)
              else                          ! defined; put it in eval stack
                  cp = cp + 1
                  if (cp .gt. CALLSIZE) then
                      call error('call stack overflow.')
                  end if
                  callst(cp) = ap
                  ap = push(ep,argstk,ap)
                  call puttok(defn)         ! stack definition
                  call putchr(EOS)
                  ap = push(ep,argstk,ap)
                  call puttok(token)        ! stack name
                  call putchr(EOS)
                  ap = push(ep,argstk,ap)
                  t = gettok(token,MAXTOK)  ! peek at next
                  call pbstr(token)
                  if (t .ne. LPAREN) then   ! add ( ) if not present
                      call pbstr(balp)
                  end if
                  plev(cp) = 0
              end if
          else if (t .eq. LBRACK) then      ! strip one level of [ ]
              nlb = 1
              loop
                  t = gettok(token,MAXTOK)
                  if (t .eq. LBRACK) then
                      nlb = nlb + 1
                  else if (t .eq. RBRACK) then
                      nlb = nlb - 1
                      if (nlb .eq. 0) then
                          exit
                      end if
                  else if (t .eq. EOF) then
                      call error('EOF in string.')
                  end if
                  call puttok(token)
              end loop
          else if (cp .eq. 0) then          ! not in a macro at all
              call puttok(token)
          else if (t .eq. LPAREN) then
              if (plev(cp) .gt. 0) then
                  call puttok(token)
              end if
              plev(cp) = plev(cp) + 1
          else if (t .eq. RPAREN) then
              plev(cp) = plev(cp) - 1
              if (plev(cp) .gt. 0) then
                  call puttok(token)
              else                         ! end of argument list
                  call putchr(EOS)
                  call eval(argstk,callst(cp),ap-1)
                  ap = callst(cp)          ! pop eval stack
                  ep = argstk(ap)
                  cp = cp - 1
              end if
          else if ((t .eq. COMMA) .and. (plev(cp) .eq. 1)) then
              call putchr(EOS)
              ap = push(ep,argstk,ap)
          else
              call puttok(token)
          end if
          t = gettok(token,MAXTOK)
      end while

      if (cp .ne. 0) then
          call error('unexpected EOF.')
      end if

      stop
      end