home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols200 / vol270 / sed4.inc < prev    next >
Text File  |  1986-05-22  |  4KB  |  145 lines
  1. procedure replaceline(xfrom,xlength:byte; line:linetype);
  2. var k:integer; i,n:byte;
  3. begin
  4.   setnumbuf; k:=ptop+1; n:=0;
  5.   for i:=1 to xfrom-1 do putmem(n,k,buffer[i]);
  6.   for i:=1 to length(line) do putmem(n,k,line[i]);
  7.   for i:=xfrom+xlength to numbuf do putmem(n,k,buffer[i]);
  8.   putmem(n,k,newline); ptop:=k-1; poptop
  9. end;
  10.  
  11. procedure connect;
  12. var i,n:byte; k:integer;
  13. begin
  14.   pushtop; n:=numbuf; k:=ptop-1; popbottom;
  15.   for i:=1 to numbuf do putmem(n,k,buffer[i]);
  16.   putmem(n,k,newline); ptop:=k-1; poptop
  17. end;
  18.  
  19. procedure searchmem(s:byte; c:char);
  20. begin
  21.   if s=1 then
  22.     begin
  23.       len:=ptop-startaddress;
  24.       if len>0 then
  25.         inline($3A/ c/ $ED/ $4B/ len/ $2A/ ptop/
  26.                $ED/ $B9/ $23/ $22/ address)
  27.     end
  28.   else if s=2 then
  29.     begin
  30.       len:=endaddress-pbotm;
  31.       if len>0 then
  32.         inline($3A/ c/ $ED/ $4B/ len/ $2A/ pbotm/
  33.                $ED/ $B1/ $2B/ $22/ address)
  34.     end
  35. end;
  36.  
  37. procedure erasemem(s:byte; mem1,mem2:integer);
  38. begin
  39.   if s=1 then
  40.     begin
  41.       len:=ptop-mem2;
  42.       if len>0 then
  43.         inline($ED/ $4B/ len/ $ED/ $5B/ mem1/ $2A/ mem2/
  44.                $23/ $ED/ $B0/ $1B/ $ED/ $53/ ptop)
  45.     end
  46.   else if s=2 then
  47.     begin
  48.       len:=mem1-pbotm;
  49.       if len>0 then
  50.         inline($ED/ $4B/ len/ $ED/ $5B/ mem2/ $2A/ mem1/
  51.                $2B/ $ED/ $B8/ $13/ $ED/ $53/ pbotm)
  52.       else if len=0 then pbotm:=mem2+1
  53.     end
  54. end;
  55.  
  56. procedure search1(c:char; var s:byte; var m:integer);
  57. begin
  58.   m:=0; s:=2; searchmem(1,c);
  59.   if mem[address]=ord(c) then s:=1 else searchmem(2,c);
  60.   if mem[address]<>ord(c) then s:=0 else m:=address
  61. end;
  62.  
  63. procedure eraseblock;
  64. var s,t:byte; mem1,mem2:integer;
  65. begin
  66.   pushtop; search1(startblock,s,mem1); search1(endblock,t,mem2);
  67.   if (mem2-mem1)>0 then
  68.     begin
  69.       if (s=t) then erasemem(s,mem1,mem2)
  70.       else if (s=1) and (t=2) then
  71.         begin
  72.           mem[mem1]:=$D; mem[mem1+1]:=$A;
  73.           ptop:=mem1+1; pbotm:=mem2+1; x:=1
  74.         end
  75.     end;
  76.   poptop
  77. end;
  78.  
  79. procedure writeblock;
  80. var s,t:byte; mem1,mem2,i:integer; name:linetype; fil:text;
  81. begin
  82.   pushtop; search1(startblock,s,mem1); search1(endblock,t,mem2);
  83.   if (s>0) and (t>0) and ((mem2-mem1)>0) then
  84.     begin
  85.       readline('write block name',name);
  86.       assign(fil,name); rewrite(fil); i:=mem1+1;
  87.       if t>s then
  88.         begin
  89.           while i<>ptop+1 do
  90.             begin write(fil,chr(mem[i])); i:=i+1 end;
  91.           i:=pbotm
  92.         end;
  93.       while i<>mem2 do
  94.         begin write(fil,chr(mem[i])); i:=i+1 end;
  95.       close(fil)
  96.     end;
  97.   poptop
  98. end;
  99.  
  100. procedure readblock;
  101. var c:char; k:integer; name:linetype; fil:text;
  102. begin
  103.   replaceline(x,0,newline); pushbottom; numbuf:=x-1; k:=ptop-1;
  104.   readline('read block name',name);
  105.   assign(fil,name); {$I-} reset(fil) {$I+};
  106.   if ioresult=0 then
  107.     begin
  108.       putmem(numbuf,k,startblock);
  109.       while not eof(fil) do
  110.         begin read(fil,c); putmem(numbuf,k,c) end;
  111.       putmem(numbuf,k,endblock)
  112.     end;
  113.   close(fil); putmem(numbuf,k,newline); ptop:=k-1; poptop; connect
  114. end;
  115.  
  116. procedure cmblock(copy:boolean);
  117. var s,t:byte; k,m,mem1,mem2:integer;
  118. begin
  119.   replaceline(x,0,newline);pushbottom; numbuf:=x-1; k:=ptop-1;
  120.   search1(startblock,s,mem1); search1(endblock,t,mem2); m:=mem1;
  121.   if ((mem2-mem1)>0) and (s=t) then
  122.     while m<>(mem2+1) do
  123.       begin putmem(numbuf,k,chr(mem[m])); m:=m+1 end;
  124.   putmem(numbuf,k,newline); ptop:=k-1;
  125.   if ((mem2-mem1)>0) and (s=t) then
  126.     if copy then
  127.       begin
  128.         if s=1 then
  129.           begin erasemem(s,mem2,mem2); erasemem(s,mem1,mem1) end
  130.         else if s=2 then
  131.           begin erasemem(s,mem1,mem1); erasemem(s,mem2,mem2) end
  132.       end
  133.     else erasemem(s,mem1,mem2);
  134.   poptop; connect
  135. end;
  136.  
  137. procedure erasemark;
  138. var s:byte; m:integer;
  139. begin
  140.   pushtop;
  141.   repeat search1(startblock,s,m); erasemem(s,m,m); until s=0;
  142.   repeat search1(endblock,s,m); erasemem(s,m,m); until s=0;
  143.   poptop
  144. end;
  145.