マクロ処理 -- 機能の追加: アナクロなコンピューターエンジニアのつぶやき

機能を2つ追加します。定義してあるマクロを取り消す--undef と簡単な条件判断を 行う--ifdef です。

undefは、以下のように使います。定義していないマクロ名を指定しても無視されます。

     define(EOF,-1) # マクロEOFの定義
          :
          :
          :
     undef(EOF)     # マクロEOFの削除

ifdefは、以下のように使います。

     define(CPU1,1)
          :
          :
          :
     ifdef(CPU1,define(WORD,4)) # CPU1が定義されていれば、WORDは、4
     ifdef(CPU2,define(WORD,8)) # CPU2が定義されていれば、WORDは、8

これらの機能を組み込むには、defineの変更が必要です。undef,ifdefを マクロテーブルに登録することと、undefルーチンuninst()の呼び出し、 ifdefの処理ロジックの追加が必要です。

RATFOR版は、

# define.r4 -- simple string replacement macro processor
      program define
      integer gettok
      character defn(MAXDEF),t,token(MAXTOK)
      integer lookup

      string defnam "define"
      string udenam "undef"
      string ifdnam "ifdef"

      character deftyp(2)
      data deftyp(1)/DEFTYPE/,deftyp(2)/EOS/
      character udftyp(2)
      data udftyp(1)/UDFTYPE/,udftyp(2)/EOS/
      character ifdtyp(2)
      data ifdtyp(1)/IFDTYPE/,ifdtyp(2)/EOS/

      call initfile
      call inittbl
      call initbuf
      call instal(defnam,deftyp)
      call instal(udfnam,udftyp)
      call instal(ifdnam,ifdtyp)

      for(t = gettok(token,MAXTOK);t != EOF;t = gettok(token,MAXTOK))
          if (t != ALPHA)               # output non-alpha tokens
              call putlin(token,STDOUT)
          else if (lookup(token,defn) == NO)
              call putlin(token,STDOUT)
          else if (defn(1) == DEFTYPE) { # get definition
              call getdef(token,MAXTOK,defn,MAXTOK)
              call instal(token,defn)
              }
          else if (defn(1) == UDFTYPE ) {
              call getnam(token,MAXTOK)
              if (lookup(token,defn) == YES) # and defined
                  call uninst(token)
              }
          else if (defn(1) == IFDTYPE) {
              call getdef(token,MAXTOK,defn,MAXDEF))
              if (lookup(token,junk) == YES)
                  call pbstr(defn)
              }
          else
              call pbstr(defn)          # push replacement
      stop
      end

WATCOM fortran 77版は、

c define.f -- simple string replacement macro processor
      program define
      integer gettok
      integer*1 defn(82),t,token(82),junk(82) ! MAXDEF(82) MAXTOK(82) MAXDEF(82)
      integer lookup
      integer*1 defnam(7)
      character $defnam(7)
      equivalence (defnam,$defnam)
      data $defnam(1)/'d'/
      data $defnam(2)/'e'/
      data $defnam(3)/'f'/
      data $defnam(4)/'i'/
      data $defnam(5)/'n'/
      data $defnam(6)/'e'/
      data defnam(7)/-2/                ! EOF(-2)
      integer*1 udfnam(6)
      character $udfnam(6)
      equivalence (udfnam,$udfnam)
      data $udfnam(1)/'u'/
      data $udfnam(2)/'n'/
      data $udfnam(3)/'d'/
      data $udfnam(4)/'e'/
      data $udfnam(5)/'f'/
      data udfnam(6)/-2/                ! EOS(-2)
      integer*1 ifdnam(6)
      character $ifdnam(6)
      equivalence (ifdnam,$ifdnam)
      data $ifdnam(1)/'i'/
      data $ifdnam(2)/'f'/
      data $ifdnam(3)/'d'/
      data $ifdnam(4)/'e'/
      data $ifdnam(5)/'f'/
      data ifdnam(6)/-2/                ! EOS(-2)
      integer*1 deftyp(2)
      data deftyp(1)/-4/,deftyp(2)/-2/  ! DEFTYPE(-4) EOS(-2)
      integer*1 udftyp(2)
      data udftyp(1)/-5/,udftyp(2)/-2/  ! UDFTYPE(-5) EOS(-2)
      integer*1 ifdtyp(2)
      data ifdtyp(1)/-6/,ifdtyp(2)/-2/  ! IFDTYPE(-6) EOS(-2)

      call initfile
      call inittbl
      call initbuf
      call instal(defnam,deftyp)
      call instal(udfnam,udftyp)
      call instal(ifdnam,ifdtyp)

      t = gettok(token,82)              ! MAXTOK(82)
      while (t .ne. -1) do              ! EOF(-1
          if (t .ne. 97) then           ! ALPHA(97) output non-alpha tokens
              call putlin(token,6)      ! STDOUT(6)
          else if (lookup(token,defn) .eq. 0) then ! NO(0) and undefined
              call putlin(token,6)      ! STDOUT(6)
          else if (defn(1) .eq. -4) then ! DEFTYPE(-4)get definition
              call getdef(token,82,defn,82) ! MAXTOK(82) MAXDEF(82)
              call instal(token,defn)
          else if (defn(1) .eq. -5) then ! UDFTYPE(-5)
              call getnam(token,82)     ! MAXTOK(82)
              if (lookup(token,defn) .eq. 1) then ! YES(1) and defined
                  call uninst(token)
              end if
          else if (defn(1) .eq. -6) then ! IFDTYPE(-6)
              call getdef(token,82,defn,82) ! MAXTOK(82) MAXDEF(82)
              if (lookup(token,junk) .eq. 1) then ! YES(1)
                  call pbstr(defn)
              end if
          else
              call pbstr(defn)          ! push replacement
          end if
          t = gettok(token,82)          ! MAXTOK(82)
      end while
      stop
      end

getnam()は、マクロ名を取り出す。

RATFOR版は、以下の通り。

# getnam.r4 -- get name
      subroutine getnam(token,toksiz)
      integer toksiz
      character token(toksiz)
      character gettok,ngetc
      character c
      integer i,nlpar

      if (ngetc(c) != LPAREN)
          call error('missing left paren.')
      else if (gettok(token,toksiz) != ALPHA)
          call error('non-alphanumeric name.')

      for (nlpar = 0; nlpar >= 0; ) 
          if (ngetc(c) == EOF)
              call error('missing right paren.')
          else if (c == LPAREN)
              nlpar = nlpar + 1
          else if (c == RPAREN)
              nlpar = nlpar - 1
          # else normal character indefn(i)
      return
      end

WATCOM fortran 77版は、

c getnam.f -- get name
      include ratfor.def
      subroutine getnam(token,toksiz)
      integer toksiz
      integer*1 token(toksiz)
      integer*1 gettok,ngetc
      integer*1 c
      integer i,nlpar

      if (ngetc(c) .ne. LPAREN) then
          call error('missing left paren.')
      else if (gettok(token,toksiz) .ne. ALPHA) then
          call error('non-alphanumeric name.')
      end if

      nlpar = 0
      while (nlpar .ge. 0) do
          if (ngetc(c) .eq. EOF) then
              call error('missing right paren.')
          else if (c .eq. LPAREN) then
              nlpar = nlpar + 1
          else if (c .eq. RPAREN) then
              nlpar = nlpar - 1
          ! else normal character indefn(i)
          end if
          i = i + 1
      end while
      return
      end

このモジュールをコンパイルするには、fid.batを使って、マクロを展開する 必要があります。

uninst()はマクロの定義を取り消します。

RATFOR版は、以下の通り。

# uninst.r4 -- undefine macro
      subroutine uninst(defnam)
      character defnam(MAXTOK)
      character name(MAXTOK),defn(MAXDEF)
      integer i,nlen,dlen
      integer length,equal
      include clook.fi

      lastt = 0
      for (i = 1; i <= lastp; i = i + 1) {
          call scopy(table,namptr(i),name,1)
          if (equal(defnam,name) == NO) {
              nlen = length(name) + 1
              call scopy(table,namptr(i) + nlen,defn,1)
              dlen = length(defn) + 1
              namptr(i) = lastt + 1
              call scopy(name,1,table,lastt+1)
              call scopy(defn,1,table,lastt+nlen+1)
              lastt = lastt + nlen + dlen
              }
          }
      lastp = lastp - 1
      return
      end

WATCOM fortran 77版は、

c uninst.f -- purge macro
      include ratfor.def
      subroutine uninst(defnam)
      integer*1 defnam(MAXTOK)
      integer*1 name(MAXTOK),defn(MAXDEF)
      integer i,nlen,dlen
      integer length,equal
      include clook.fi

      lastt = 0
      i = 1
      while (i .le. lastp) do
          call scopy(table,namptr(i),name,1)
          if (equal(defnam,name) .eq. NO) then
              nlen = length(name) + 1
              call scopy(table,namptr(i) + nlen,defn,1)
              dlen = length(defn) + 1
              namptr(i) = lastt + 1
              call scopy(name,1,table,lastt+1)
              call scopy(defn,1,table,lastt+nlen+1)
              lastt = lastt + nlen + dlen
          end if
          i = i + 1
      end while
      lastp = lastp - 1
      return
      end

getnam()uninst()にincludeするratfor.defは、以下の通り。

c ratfor.def -- ratfor constants
define(LET0,48)
define(LET1,49)
define(LET2,50)
define(LET3,51)
define(LET4,52)
define(LET5,53)
define(LET6,54)
define(LET7,55)
define(LET8,56)
define(LET9,57)
define(LETA,65)
define(LETB,66)
define(LETC,67)
define(LETD,68)
define(LETE,69)
define(LETF,70)
define(LETG,71)
define(LETH,72)
define(LETI,73)
define(LETJ,74)
define(LETK,75)
define(LETL,76)
define(LETM,77)
define(LETN,78)
define(LETO,79)
define(LETP,80)
define(LETQ,81)
define(LETR,82)
define(LETS,83)
define(LETT,84)
define(LETU,85)
define(LETV,86)
define(LETW,87)
define(LETX,88)
define(LETY,89)
define(LETZ,90)
define(LETa,97)
define(LETb,98)
define(LETc,99)
define(LETd,100)
define(LETe,101)
define(LETf,102)
define(LETg,103)
define(LETh,104)
define(LETi,105)
define(LETj,106)
define(LETk,107)
define(LETl,108)
define(LETm,109)
define(LETn,110)
define(LETo,111)
define(LETp,112)
define(LETq,113)
define(LETr,114)
define(LETs,115)
define(LETt,116)
define(LETu,117)
define(LETv,118)
define(LETw,119)
define(LETx,120)
define(LETy,121)
define(LETz,122)
define(STDIN,5)
define(STDOUT,6)
define(ERROUT,6)
define(EOF,-1)
define(EOS,-2)
define(TAB,9)
define(NEWLINE,10)
define(BLANK,32)
define(BUFSIZE,1000)
define(LETTER,97)
define(DIGIT,48)
define(MAXLINE,82)
define(MAXDEF,82)
define(MAXTOK,82)
define(MAXPTR,500)
define(MAXTBL,5000)
define(ARGSIZE,82)
define(DEFTYPE,-4)
define(IFDTYPE,-5)
define(UDFTYPE,-6)
define(IFTYPE,-7)
define(INCTYPE,-8)
define(SUBTYPE,-9)
define(LENTYPE,-10)
define(EVALSIZE,1000)
define(ALPHA,LETa)
define(NO,0)
define(YES,1)
define(LPAREN,40)
define(RPAREN,41)
define(LBRACK,91)
define(RBRACK,93)
define(COMMA,44)
define(DQUOTE,34)
define(QUOTE,39)
define(SEMICOL,59)
define(CALLSIZE,1000)
define(DOLLAR,36)
define(ARGFLAG,36)
define(DNL,36)
define(EXCLAM,33)