const max_err=6500000;
type t_mem=array[0..$FFFE]of byte;
var
fl:file;
a:^t_mem;
dat:byte;
err:longint;
pos:word;
procedure error(ms:string;_pos:word);
begin
writeln('ошибка приема ',ms,' в позиции ',_pos);
halt;
end;
procedure getDats(var ddt:byte);
 begin
err:=0;
repeat
inc(err);
if err>max_err then error('LO',0);
until (port[$037A] and $04)<>0;
dat:=(port[$0379] shr 3)and$0F;
err:=0;
repeat
inc(err);
if err>max_err then error('HI',0);
until (port[$037A] and $04)=0;
ddt:=((port[$0379] shl 1)and$F0)or dat;
 end;

begin
new(a);

assign(fl,'c:\dos.rom');
rewrite(fl,1);
writeln('Get dats...');
for pos:=0 to 16383 do
 begin
getDats(dat);
a^[pos]:=dat;
 end;
writeln('Write result...');
blockwrite(fl,a^,16384);
close(fl);
writeln('Ok');
dispose(a);
end.