fgetc()fputf()再掲 ― 2015年04月12日 15:50
紹介しましたincludeですが、不具合が見つかりました。調べてみると、fgetc(),fputc()に原因がありました。不具合を改善したfgetc(),fputc()を掲載します。
これに関連して、files.fi,initfile(),fopen()も変更が必要です。
変更点は、以下の通りです。
- 最後の文字位置をlastcr,lastcwで記憶
- READWRITEでファイルを開けられるように対応
- fnewで改行を超えたことを明示
- getlin(),putlin()のバッファーをMAXLINE+1に変更
まずは、files.fi。
c files.fi -- file interface common valiables
common /files/finuse(20),fbuf(20,81),flastcr(20),flastcw(20),
1 fmode(20),fnew(20)
! MAXFILES(20) MAXLINE(81)
integer finuse ! inuse flag
integer*1 fbuf ! I/O buffer
integer flastcr ! characters in read buffer
integer flastcw ! characters in write buffer
integer*1 fmode ! READ/WIRTE flag
integer fnew ! NEWLINE flag
変数、flastcに代わって、flastcr,flastcwを使用します。これは、READWRITEでファイルを開けた時に、正常に動作するようにするためです。 また、fnewを追加しました。これは、NEWLINEを超えた時にセットされ、次行を読み込むスイッチになります。
fopen()です。
c fopen.for -- connect intenal file descripter and external file
integer function fopen(uid, fn, act)
integer uid
integer*1 fn(*), act
integer i
character*81 cfn ! MAXNAME(81)
character*9 cact ! READ WRITE
include 'files.fi'
if (act .eq. 82) then ! READ(LETR)
cact = 'READ'
else if (act .eq. 87) then ! WRITE(LETW)
cact = 'WRITE'
else if (act .eq. 66) then ! READWRITE(LETB)
cact = 'READWRITE'
else ! error
uid = -1 ! ERR(-1)
fopen = -1 ! ERR(-1)
return
end if
call is2cs(fn,cfn,81) ! MAXNAME(81) convert integer string to character string
i = 1
while (i .le. 20) do ! MAXFIELS(20)
if (finuse(i) .eq. 0) then ! NOUSE(0)
open(unit=i, file=cfn, action=cact, err=99)
finuse(i) = 1 ! INUSE(1)
uid = i
fopen = i
if (act .eq. 82) then ! READ(LETR)
flastcr(i) = 80 + 1 ! MAXCARD(80)
fbuf(i,81) = 10 ! MAXLINE(81) NEWLINE(10)
fnew(i) = 0 ! NO(0)
fmode(i) = act ! READ(LETR)
else if (act .eq. 87) then ! WRITE(LETW)
flastcw(i) = 0
fmode(i) = act ! WRITE(LETW)
else if (act .eq. 66) then ! READWRITE(LETB)
flastcr(i) = 80 + 1 ! MAXCARD(80)
flastcw(i) = 0
fbuf(i,81) = 10 ! MAXLINE(81) NEWLINE(10)
fnew(i) = 0 ! NO(0)
fmode(i) = act ! READWRITE(LETB)
end if
return
endif
i = i + 1
end while
99 continue
uid = -1 ! ERR(-1)
fopen = -1 ! ERR(-1)
return
end
flastcr,flastcwの初期設定と、READWRITEでファイルを開けた時の処理を追加しています。
fgetc()を次に示します。
c fgetc.for -- (extended version) get character from unit u
integer*1 function fgetc(u,c)
integer u
integer*1 c
integer i
include 'files.fi'
flastcr(u) = flastcr(u) + 1
if ((flastcr(u) .gt. 81) .or. (fnew(u) .eq. 1)) then ! MAXCARD(80) YES(1)
read(u,10,end=9) (fbuf(u,i),i=1,80) ! MAXCARD(80)
10 format(80a1) ! MAXCARD(80)
flastcr(u) = 1
fnew(u) = 0 ! NO(0)
i = 80 ! MAXCARD(80)
while (fbuf(u,i) .eq. 32) do ! BALNK(32)
i = i - 1
end while
fbuf(u,i + 1) = 10 ! NEWLINE(10)
endif
c = fbuf(u,flastcr(u))
fgetc = fbuf(u,flastcr(u))
if (c .eq. 10) then ! NEWLINE(10)
fnew(u) = 1 ! YES(1)
end if
return
9 continue
c = -1 ! EOF(-1)
fgetc = -1 ! EOF(-1)
return
end
fnewを使て、行末を超えたことを判断するロジックを追加しています。
fputc()は、以下の通りです。
c fputc.for (extended version) -- put character on file
subroutine fputc(u,c)
integer i,u
integer*1 c
include 'files.fi'
if ((c .eq. -1) .and. (flastcw(u) .eq. 0)) then
return ! buffer is empty, nothing to do
end if
if ((flastcw(u) .ge. 80) .or. (c .eq. 10) .or. (c .eq. -1)) then
! MAXCARD(80) NEWLINE(10) EOF(-1)
write(u,10) (fbuf(u,i),i=1,flastcw(u))
10 format(80a1) ! MAXCARD(80)
flastcw(u) = 0
end if
if (c .ne. 10) then ! NEWLINE(10)
flastcw(u) = flastcw(u) + 1
fbuf(u,flastcw(u)) = c
end if
return
end
flastcwでロジックを組み立てています。
これ以外に、入出力ルーチンを念のため確認したところ,getlin(),putlin()を改修しました。
getlin()を以下に示します。
c getlin.for -- get line from infile
integer function getlin(line,u)
integer*1 line(81+1) ! MAXLINE(81)+1
integer u
integer*1 c,fgetc
integer col
while (fgetc(u,c) .ne. -1) do ! EOF(-1)
col = 0
while (c .ne. 10) do ! NEWLINE(10)
col = col + 1
line(col) = c
c = fgetc(u,c)
end while
line(col + 1) = 10 ! NEWLINE(10)
line(col + 2) = -2 ! EOS(-2)
getlin = col
return
end while
getlin = -1 ! EOF(-1)
return
end
putlin()を以下に示します。
c putlin.for -- put lin to u
subroutine putlin(lin,u)
integer*1 lin(81+1) ! MAXLINE(81)+1
integer u,i
i = 1
while (lin(i) .ne. -2) do ! EOS(-2)
call fputc(u,lin(i))
i = i + 1
end while
return
end
以上の変更をしたのち、ライブラリーを再構築したのち、includeを作成してください。
concatとxprint ― 2015年04月19日 09:16
ファイルを使ったプログラムを2つ紹介します。concatとxprintです。
まずは、concatから。
concatは、引数にファイルを指定します。指定したファイルをひとつながりにして標準出力に書き出します。
concat file1 file2 file2 ...
concatのメイン部分は下記の通り。引数がなくなるまで取り出し、 取り出してはファイルをオープンし標準出力に書き出します。
RATFOR版は下記の通り。
# concat.r4 -- concatenate named files onto standard output
character name(NAMESIZE)
integer getarg, fopen
integer fin,i
call initfile()
for (i = 1; getarg(i,name,NAMESIZE) != EOF; i = i + 1) {
fin = fopen(fin,name,READ)
if (fin == ERR)
call cant(name)
end if
call fcopy(fin,STDOUT)
call fclose(fin)
}
stop
end
WATCOM fortran77版は下記の通り。
c concat.for -- concatinate named files onto standard output
program concat
integer getarg,fopen
integer fin,i
integer*1 name(81) ! NAMESIZE(81)
call initfile()
i = 1
while (getarg(i,name,81) .ne. -1) do ! NAMESIZE(81) EOF(-1)
if (fopen(fin,name,82) .eq. -1) then ! READ(LETR) ERR(-1)
call cant(name)
end if
call fcopy(fin,6) ! STDOUT(6)
call fclose(fin)
i = i + 1
end while
stop
end
実際の書き出しはfcopy()が行います。fcopy()は次の通り。
まずは、RATFOR版。
# fcopy.r4 -- copy file in to file out
subroutine fcopy(in,out)
integer in,out
character buf(MAXLINE+1)
integer getlin
while (getlin(buf,in) != EOF)
call putlin(buf,out)
return
end
このように、単純に入力を出力に書き出します。
WATCOM Fortran77版。
c fcopy.for -- copy file in to file out
subroutine fcopy(in,out)
integer in,out
integer*1 buf(81+1) ! MAXLINE(81)+1
integer getlin
while (getlin(buf,in) .ne. -1) do ! EOF(-1)
call putlin(buf,out)
end while
return
end
次に、xprintです。xprintは、ファイルを、1ページに、ファイル名とページ番号を適当に書き出すものです。
引数がなかった場合は、標準入力から読み込みます。この時はヘッダー部分にファイル名を書きません。
xprintのメインは下記の通り。
まずは、RATFOR版。
# xprint (default input STDIN)-- print files with headings
character name(NAMESIZE)
integer getarg,fopen
integer fin,i
string null ""
call initfile()
for (i = 1; getarg(i,name,NAMESIZE) != EOF; i = i + 1) {
if (fopen(fin,name,READ) == ERR)
call cant(name)
end if
call fprint(name,fin)
call fclose(fin)
}
if (i == 1)
call fprint(null,STDIN)
stop
end
WATCOMFortran77版は下記の通り。
c xprint (default input STDIN)-- print files with headings
program xprint
integer*1 name(81) ! NAMESIZE(81)
integer getarg,fopen
integer fin,i
integer*1 null
data null/' '/
call initfile()
i = 1
while(getarg(i,name,81) .ne. -1) do ! NAMESIZE(81) ERR(-1)
if (fopen(fin,name,82) .eq. -1) then ! READ(LETR) ERR(-1)
call cant(name)
end if
call fprint(name,fin)
call fclose(fin)
i = i + 1
end while
if (i .eq. 1) then
call fprint(null,5) ! STDIN(5)
end if
stop
end
使い方は、下記の通り。
xprint file
実際の書き出しは、fprint()が行います。fprint()は下記の通り。
RATFOR版です。
# fprint.r4 -- print file name from fin
subroutine fprint(name,fin)
character name(NAMESIZE),line(MAXLINE+1)
integer fin,lineno,pageno
integer getlin
lineno = 0
pageno = 0
while (getlin(line,fin) != EOF) {
if (lineno == 0) {
call skip(MARGIN1)
pageno = pageno + 1
call head(name,pageno)
call skip(MARGIN2)
loneno = MARGIN1 + MARGIN2 + 1
}
call putlin(line,STDOUT)
lineno = lineno + 1
if (lineno >= BOTTOM) {
call skip(PAGELEN-lineno)
lineno = 0
}
}
if (lineno > 0)
call skip(PAGELEN-lineno)
return
end
WATCOM Fortran77版は下記の通り。
c fprint.for -- print file name from fin
subroutine fprint(name,fin)
integer*1 name(81) ! NAMESIZE(81)
integer fin
integer*1 line(81+1) ! MAXLINE(81)
integer getlin,lineno,pageno
lineno = 0
pageno = 0
while (getlin(line,fin) .ne. -1) do ! EOF(-1)
if (lineno .eq. 0) then
call skip(2) ! MARGIN1(2)
pageno = pageno + 1
call head(name,pageno)
call skip(3) ! MARGIN2(3)
loneno = 2 + 3 + 1
endif
call putlin(line,6) ! STDOUT(6)
lineno = lineno + 1
if (lineno .ge. 62) then ! BOTTOM(62)
call skip(66-lineno) ! PAGELEN(66)
lineno = 0
endif
end while
if (lineno .gt. 0) then
call skip(66-lineno) ! PAGELEN(66)
end if
return
end
MARGIN1,MARGIN2,BOTTOM,PAGELENはLetterサイズの用紙に合わせてありますので、 A4に書き出すときは変更が必要です。また、1行80文字で書き出すので、A4縦では はみ出してしまいますので、注意が必要です。
下請けルーチンのskip()は下記の通り。指定された分だけ改行を出力します。
RATFOR版。
# skip.r4 -- output n blank lines
subroutine skip(n)
integer i,n
for (i = 1; i <= n; i = i + 1)
call putc(NEWLINE)
return
end
WATCOM Fortran77版。
c skip.for -- output n blank lines
subroutine skip(n)
integer i,n
i = 1
while (i .le. n) do
call putc(10) ! NEWLINE(10)
i = i + 1
end while
return
end
また、ヘッダーを書くhead()は下記の通り。
RATFOR版。
# head.r4 -- print top of page header
subroutine head(name,pageno)
character name(NAMESIZE)
integer pageno
string page " page "
call putlin(name,STDOUT)
call putlin(page,STDOUT)
call putdec(pageno,1)
call putc(NEWLINE)
return
end
WATCOMM Fortran版。
c head.for -- print top of page header
subroutine head(name,pageno)
integer*1 name(81) ! NAMESIZE(81)
integer pageno
integer*1 page(8)
data page/' ',' ','p','a','g','e',' ',-2/ ! EOS(-2)
call putlin(name,6) ! STDOUT(6)
call putlin(page,6) ! STDOUT(6)
call putdec(pageno,1)
call putc(10) ! NEWLINE(10)
return
end
最近のコメント