引数付きマクロ処理 -- 機能拡張(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,"()")は、うまく展開できない。
最近のコメント