引数付きマクロ処理 -- 機能拡張(1) ― 2017年04月14日 12:39
マクロが動くようになったので、バッチファイル"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
引数付きマクロ処理 -- 機能拡張(2) ― 2017年04月14日 19:53
組み込み関数"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,"()")
は、うまく展開できない。
引数付きマクロ処理 -- 機能改善 ― 2017年04月21日 13:54
完成した"macro"を使ってみて、以下の不具合が見つかった。
- マクロの外で、'や"で囲まれた文字列(たいていの場合文字列定数)に含まれるマクロ名も置換されてしまう。
- マクロ"string"は、英数字しか展開できない。
- マクロ"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))])])
Ratforプリプロセッサー -- RatforからFortranへの変換 ― 2017年04月29日 09:51
ここまで、Ratforで書かれたプログラムを手作業でWATCOM Fortran 77でコンパイル できるよう修正してきた。これから、RatforのコードからFortran IVのレベルのコードに変換する プリプロセッサーを紹介する。
これまでに作成したツールとプリプロセッサーを使って、 Ratforで書かれたプログラムを実行可能なプログラムにする手順は、 以下のようになる。
,--------------,
| Ratfor |
| 原プログラム |
'--------------'
|
V .------------.
[include]<------| Ratfor.def |
| '------------'
V
[macro]
|
V
[ratfor]
|
V
[Watcom Fortran77]
|
V
.------------.
| 実行可能な |
{ プログラム |
'------------'
ところで、Ratfor言語の定義をBNFで記述すると以下のようになる。
プログラム : 文
| プログラム 文
文 : if ( 条件 ) 文
| if ( 条件 ) 文 else 文
| while ( 条件 ) 文
| for ( 初期設定; 条件; 再設定 ) 文
| repeat 文
| repeat 文 until ( 条件 )
| do 限界指定部 文
| 数字の列 文
| break
| next
| { プログラム }
| その他
Ratfor言語は、10種類程度の文からなっており、"その他"とはRatforが知らない文でFortranの 文が該当する。Ratforは、"if"や"while" などの制御構造を持った文をFortranの"if","go to","continue"などを 使って、制御構造を作りだすのである。
文の変換規則(コード変換規則)は、以下のようになる。
"if" 文
if ( 条件 ) 文
は、
if (.not. ( 条件 )) goto L
文
L continue
"if--else" 文
if ( 条件 ) 文1 else 文2
は、
if (.not. ( 条件 )) goto L
文1
go to L1
L continue
文2
L1 continue
"while" 文
while ( 条件 ) 文
は、
continue
L if (.not. ( 条件 )) go to L1
文
go to L
L1 continue
"for" 文
for ( 初期設定; 条件; 再設定 ) 文
は、
continue
初期設定
L if (.not. ( 条件 )) goto L2
文
L1 continue
再設定
goto L
L2 continue
"repeat" 文
repeat 文
は、
continue
L continue
文
L1 continue
go to L
L2 continue
"repeat-until" 文
continue
L continue
文
L1 continue
if (.not. ( 条件 )) go to L
L2 continue
"do" 文
do 限界指定部 文
は、
do L 限界指定部
文
L1 continue
L continue
"break"文は、"while"、"for"、"repeat"、"repeat-until"、"do"のループから抜け出すのに使用できる。 すなわち、ループの次の文に制御が移る。
"next"文は、ループの残りをジャンプして次の繰り返しに制御を移す。 "while"、"repeat-until"、"do"の各ループでは、条件判定部に、 "for"では、再設定に、"repeat"では、ループ本体の先頭に、それぞれ制御が移る。
論理式に使う演算子"<"や"&"等は、変換される。
Ratforの演算子 Fortranの演算子
-------------- ---------------
> .gt.
>= .ge.
< .lt.
<= .le.
== .eq.
!= .ne.
! .not.
& .and.
| .or.
最近のコメント