マクロ処理 -- 表の検索 ― 2017年01月12日 21:26
マクロ名と置き換え文字列の対応表を取り扱うのか、lookup()、とinstal()である。 lookup()は表の検索をinstal()は表に新たなマクロを登録する。いずれにしても、表の データ構造に依存するコードになる。表は単純な次のような構造とする。
名前 EOS 置き換え文字列 EOS 名前 EOS 置き換え文字列 EOS ,,,,,,,,,,,,
また、上の表のどの位置に名前があるのかを示す指標を第2の配列に保持する。
これらの共通ブロックは、次のようになる。
RATFOR版は、
# clook.r4
common /clook/lastp,lastt,namptr(MAXPTR),table(MAXTBL)
integer lastp # last used in namptr; init = 0
integer lastt # last used in table; init = 0
integer namptr # name pointers
character table # actual text of names and defns
WATCOM fortran 77版は、
c clook.fi
common /clook/lastp,lastt,namptr(500),table(5000) ! MAXPTR(500) MAXTBL(5000)
integer lastp ! last used in namptr; init = 0
integer lastt ! last used in table; init = 0
integer namptr ! name pointers
integer*1 table ! actual text of names and defns
lookup()は以下の通り。
RATFOR版は、
# lookup.r4 -- locate name, extract definition from table
integer function lookup(name,defn)
character name(MAXDEF),defn(MAXTOK)
integer i,j,k
include clook.fi
for (i = lastp;i > 0; i = i - 1) {
j = namptr(i)
for (k = 1;name(k) == table(j) & name(k) != EOS; k = k + 1)
j = j + 1
if (name(k) == table(j)) { # got one
call scopy(table,j+1,defn,1)
lookup = YES
return
}
}
lookup = NO
return
end
WATCOM fortran 77版は、
c lookup.f -- locate name, extract definition from table
integer function lookup(name,defn)
integer*1 name(82),defn(82) ! MAXDEF(82) MAXTOK(82)
integer i,j,k
include clook.fi
i = lastp
while (i .gt. 0) do
j = namptr(i)
k = 1
while ((name(k) .eq. table(j)) .and. (name(k) .ne. -2)) do ! EOS(-2)
j = j + 1
k = k + 1
end while
if (name(k) .eq. table(j)) then ! got one
call scopy(table,j+1,defn,1)
lookup = 1 ! YES(1)
return
end if
i = i - 1
end while
lookup = 0 ! NO(0)
return
end
instal()は、以下の通り。
RATFOR版は、
# instal.r4 -- add name and definition to table
subroutine instal(name,defn)
character name(MAXTOK),defn(MAXDEF)
integer length
integer dlen,nlen
include clook.ri
nlen = length(name) + 1
dlen = length(defn) + 1
if (lastt+nlen+dlen > MAXTBL | lastp >= MAXPTR) {
call putlin(name,ERROUT)
call remark(':too many definitions.')
}
lastp = lastp + 1
namptr(lastp) = lastt + 1
call scopy(name,1,table,lastt+1)
call scopy(defn,1,table,lastt+nlen+1)
lastt = lastt + nlen + dlen
return
end
WATCOM fortran 77版は、
c instal.f -- add name and definition to table
subroutine instal(name,defn)
integer*1 name(82),defn(82) ! MAXTOK(82) MAXDEF(82)
integer length
integer dlen,nlen
include clook.fi
nlen = length(name) + 1
dlen = length(defn) + 1
if ((lastt+nlen+dlen .gt. 5000) .or. (lastp .ge. 500)) then ! MAXTBL(5000) MAXPTR(500)
call putlin(name,6) ! ERROUT(6)
call remark(':too many definitions.')
end if
lastp = lastp + 1
namptr(lastp) = lastt + 1
call scopy(name,1,table,lastt+1)
call scopy(defn,1,table,lastt+nlen+1)
lastt = lastt + nlen + dlen
return
end
表の初期化は、inittbl()で行う。
RATFOR版は、
# inittbl.r4 -- initialize macro table
subroutine inittbl
include clook.ri
lastp = 0
lastt = 0
return
end
WATCOM fortran 77版は、
c inittbl.f -- initialize macro table
subroutine inittbl
include clook.fi
lastp = 0
lastt = 0
return
end
ここまでで、defineが動き出した。実際の運用は、マクロ定義は別ファイルで 行い、ソースファイルでそれをインクルードし、その結果をdefineに通すようにするとよい。 これを支援するバッチファイルfid.batを以下に示す。
@echo off
rem fid.bat
cd ..\src
..\exe\include < %1.f | ..\exe\define > %1.for
cd ..\bat
マクロ処理 -- 機能の追加 ― 2017年01月13日 21:19
機能を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)
引数付きマクロ処理(一部修正) ― 2017年01月26日 21:27
マクロの定義に、引数が使えるようになると、利便性が非常に向上する。簡単な例を 示す。まずは、マクロの定義は、以下のようになる。マクロgetc,putcの定義の中、$1が マクロの引数にである。引数は、$1から$9までである。
define(STDIN,5)
define(STDOUT,6)
define(getc,getch(STDIN,$1))
define(putc,putch(STDOUT,$1))
プログラム中では、以下のように、記述する。
c = getc(c)
call putc(c)
これが展開されると、以下のようになる。
c = getch(5,c)
call putch(6,c)
もう少し長いマクロの例を以下に示す。
define(BLANK,32)
define(TAB,9)
define(skipbl,while($1($2) == BLANK | $1($2) == TAB)
$2 = $2 + 1)
プログラム中では、
skipbl(s,i)
展開されると、
while(s(i) == 32 | s(i) == 9)
i = i + 1
読み込み中にマクロに出会ったら、引数も含めてマクロ評価用スタックに積む。 引数の中にマクロ呼び出しがあったら、新しいマクロ評価用スタック領域を取り、 スタックに積む。そして、マクロを完全に評価して、入力に送り返す。そして、元の マクロの評価を続ける。
マクロ評価用スタックevalstは配列で表現され、マクロの名前、定義型、 引数が入る。一方、配列argstkは、evalstに格納された文字列の場所の 位置を示す。いくつものモジュールで共通の用いられるevalstは以下の通り。
RATFOR版は、
# cmacro.ri
common /cmacro/cp,ep,evalst(EVALSIZE)
integer cp # current call stack pointer
integer ep # next free position in evalst
character evalst # evaluation stack
WATCOM fortran 77版は、
! cmacro.fi
common /cmacro/cp,ep,evalst(EVALSIZE)
integer cp ! current call stack pointer
integer ep ! next free position in evalst
integer*1 evalst ! evaluation stack
このマクロでは、マクロや組み込み操作は出現したとき、 その場で全て展開することになっているので、それではまずいことがある。 たとえば、defをdefineの同義語として定義したいとき、
define(def,define($1,$2))
とすれば良さそうだが、うまくいかない。まず、マクロ名"def"が、評価用スタックに積まれる。 次に、置き換え文字列"define($1,$2)"が評価されてしまい、"def"に対応する置き換え文字列が 空となってしまう。 これでは、目的を達成できないので、"["と"]"でくくられた範囲は、評価を遅らせる仕組みを 付け加える。
define(def,[define($1,$2)])
def(ABC,DEF)
とすると
ABC
は、変換されて、
DEF
となる。実は、引数なしのマクロプログラムのソースは、defineを通せない。 プログラム中のマクロ定義ではない"define"文字列がマクロの定義と 見間違えられてしまうのである。
引数なしのマクロには、"()"がつかない、これを特別扱いしないように、 "()"がついていないマクロに出会ったら、"()"を入力に送り返し、あたかも"()"が つぃているかのように振る舞わせる。
以上を踏まえた、引数付きマクロのRATFOR版は、以下の通り。
# macro.r4 -- expand macros with arguments
program macro
character gettok
integer*1 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/
include cmacro.fi
call initfile
call inittbl
call instal(defnam,deftyp)
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) 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
}
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版は、
! 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/
include cmacro.fi
call initfile
call inittbl
call instal(defnam,deftyp)
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
下請けルーチンputtok()のRATFOR版は、以下の通り。
# puttok.r4 -- put a token either on output or into evaluation stack
subroutine puttok(str)
character str(MAXTOK)
integer i
for (i = 1; str(i) != EOS; i = i + 1)
call putchr(str(i))
return
end
WATCOM fortran 77版は、
! puttok.f -- put a token either on output or into evaluation stack
include ratfor.def
subroutine puttok(str)
integer*1 str(MAXTOK)
integer i
i = 1
while (str(i) .ne. EOS) do
call putchr(str(i))
i = i + 1
end while
return
end
下請けルーチンputchr()のRATFOR版は、以下の通り。
# putchr -- put single char on output or into eveluation stack
subroutine putchr(c)
character c
include cmacror.ri
if (cp == 0)
call putc(c)
else {
if (ep > EVALSIZE)
call error('eveluation stack overflow.')
evalst(ep) = c
ep = ep + 1
}
return
end
WATCOM fortran 77版は、
! putchr -- put single char on output or into eveluation stack
include ratfor.def
subroutine putchr(c)
integer*1 c
include cmacro.fi
if (cp .eq. 0) then
call putc(c)
else
if (ep .gt. EVALSIZE) then
call error('eveluation stack overflow.')
end if
evalst(ep) = c
ep = ep + 1
end if
return
end
下請けルーチン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 {
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版は、
! 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
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
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
下請けルーチンdodef()のRATFOR版は、以下の通り。
# dodef.rf -- install definition in table
subroutine dodef(argstk,i,j)
integer i,j,argstk(ARGSIZE)
integer a2,a3
include cmacro.ri
if (j-i .gt. 2) {
a2 = argstk(i+2)
a3 = argstk(i+3)
call instal(evalst(a2),evalst(a3)) # subarrays
}
return
end
WATCOM fortran 77版は、
! dodef.f -- install definition in table
include ratfor.def
subroutine dodef(argstk,i,j)
integer i,j,argstk(ARGSIZE)
integer a2,a3
include cmacro.fi
if (j-i .gt. 2) then
a2 = argstk(i+2)
a3 = argstk(i+3)
call instal(evalst(a2),evalst(a3)) ! subarrays
end if
return
end
最近のコメント