DataMuseum.dk

top - download

    Length: 3867 (0xf1b)
    Types: TextFile
    Names: »EXTEND.PAS«

└─⟦b6837b237⟧ Bits:30010500 SW2103 REL 1.11 Sourcer DVBS1.SW2103.rel.1.11-1 MASTER 31-1-192
    └─⟦this⟧ »EXTEND.PAS« 

TextFile

program extend;\r
uses rtpunit, dos;\r
\r
const\r
filmax = 256;\r
type\r
filrec = array[1..filmax] of integer;\r
var\r
fil1, fil2 : file;\r
fil1_ix    : integer;\r
fil1_rec   : integer;\r
fil1_ptr   : ^filrec;\r
fil2_ix    : integer;\r
fil2_rec   : integer;\r
fil2_ptr   : ^filrec;\r
i, sep, paramno, call_line_number : integer;\r
ok, eof1, swap1 : boolean;\r
max1_last, max1_rec: integer;\r
help_long: longint;\r
\r
call_line_name: alfa;\r
output_file_name, fil1_name, fil2_name: alfa;\r
\r
const\r
\r
(* constants and variables concerning call parameter reading *)\r
equal = 6; space = 4; dot = 8;\r
name  = 10; int = 4;\r
power8 = 256;\r
\r
procedure in_fil1(var p: integer);\r
var count: integer;\r
begin\r
  fil1_ix := fil1_ix + 1;\r
  if fil1_ix > filmax then\r
  begin\r
    fil1_rec := fil1_rec + 1;\r
    fil1_ix := 1;\r
    if fil1_rec < max1_rec then count := filmax else count := max1_last;\r
    blockread(fil1, fil1_ptr^, count);\r
  end;\r
  p := fil1_ptr^[fil1_ix];\r
(*$R-*)\r
  if swap1 then p := swap(p);\r
(*$R+*)\r
  eof1 := (fil1_ix = max1_last) and (fil1_rec = max1_rec);\r
end;\r
\r
\r
procedure out_fil2(p: integer);\r
begin\r
  fil2_ix := fil2_ix + 1;\r
  if fil2_ix > filmax then\r
  begin\r
    fil2_ix := 1;\r
    blockwrite(fil2, fil2_ptr^, filmax);\r
  end;\r
  fil2_ptr^[fil2_ix] := p;\r
end;\r
\r
procedure paramerror(place: integer);\r
begin\r
write(output,'*** compare, error in call(',place:1,paramno:1,'): ');\r
if sep=0 then\r
write(output, 'missing parameter')\r
else\r
repeat\r
if sep div power8 = space then\r
write(output,' ')\r
else\r
write(output,'-');\r
if sep mod power8 = name then\r
write(output,call_line_name)\r
else\r
write(output,call_line_number:1);\r
paramno:= paramno + 1;\r
sep:= paramread (paramno, call_line_number, call_line_name);\r
if sep = 0 then sep:= space * power8;\r
until sep div power8 = space;\r
writeln(output);\r
ok:= false;\r
paramno:= paramno - 1;\r
end;\r
\r
function getint : integer;\r
var\r
p: integer;\r
begin\r
p:= paramread (paramno + 1, call_line_number, call_line_name);\r
if p = dot * power8 + int then\r
begin\r
getint:= call_line_number;\r
paramno:= paramno + 1;\r
end\r
else\r
begin\r
paramerror(0);\r
getint:= 0;\r
end;\r
end;\r
\r
procedure get_parameters;\r
\r
begin (* body of getparams *)\r
ok:= true;\r
sep:= paramread (1, call_line_number, call_line_name);\r
if sep div power8 = equal then\r
begin\r
sep:= paramread (0, call_line_number, output_file_name);\r
paramno:= 2;\r
end\r
else\r
paramno:= 1;\r
\r
sep:= paramread (paramno, call_line_number, fil1_name);\r
if sep <> space * power8 + name then\r
paramerror(1);\r
paramno:= paramno + 1;\r
sep:= paramread (paramno, call_line_number, fil2_name);\r
if sep = dot * power8 + name then\r
begin\r
  if fil2_name = 'swap' then swap1 := true;\r
  paramno := paramno + 1;\r
end;\r
\r
sep := paramread(paramno, call_line_number, fil2_name);\r
if sep <> space * power8 + name then\r
paramerror(2);\r
paramno:= paramno + 1;\r
sep := paramread(paramno, call_line_number, call_line_name);\r
if sep = dot * power8 + name then\r
begin\r
  paramno := paramno + 1;\r
  sep:= paramread (paramno, call_line_number, call_line_name);\r
end;\r
\r
if not ok then\r
begin\r
writeln(output,' call syntax is:');\r
writeln(output,\r
'extend <infil(-swap)> <outfil>');\r
rtphalt(false);\r
end; (* not ok *)\r
end;\r
\r
begin\r
\r
sep              := 0;\r
paramno          := 0;\r
call_line_number := 0;\r
ok               := true;\r
\r
swap1            := false;\r
\r
fil1_rec         := -1;\r
fil2_rec         := -1;\r
fil1_ix          := filmax;\r
fil2_ix          := 0;\r
new(fil1_ptr);\r
new(fil2_ptr);\r
\r
get_parameters;\r
\r
assign(fil1, fil1_name);\r
reset(fil1, 2);\r
assign(fil2, fil2_name);\r
rewrite(fil2, 2);\r
\r
help_long := filesize(fil1);\r
max1_rec  := (help_long-1) div filmax;\r
max1_last := help_long - max1_rec*filmax;\r
eof1      := help_long = 0;\r
\r
while not eof1 do\r
begin\r
  in_fil1(i);\r
  out_fil2(i);\r
end;\r
\r
for i := fil2_ix to filmax do out_fil2(0);\r
\r
close(fil1);\r
close(fil2);\r
end.«eof»