Trailing-Edge
-
PDP-10 Archives
-
tops10_tools_bb-fp64b-sb
-
10,7/amis/buffer.pas
There are no other files named buffer.pas in the archive.
(* AMIS buffer handler. *) (* -*-PASCAL-*- *)
(****************************************************************************)
(* *)
(* Copyright (C) 1980, 1981, 1982, 1983, 1984, 1985, 1986, 1987 by *)
(* Stacken, Royal Institute Of Technology, Stockholm, Sweden. *)
(* All rights reserved. *)
(* *)
(* This software is furnished under a license and may be used and copied *)
(* only in accordance with the terms of such license and with the *)
(* inclusion of the above copyright notice. This software or any other *)
(* copies thereof may not be provided or otherwise made available to any *)
(* other person. No title to and ownership of the software is hereby *)
(* transferred. *)
(* *)
(* The information in this software is subject to change without notice *)
(* and should not be construed as a commitment by Stacken. *)
(* *)
(* Stacken assumes no responsibility for the use or reliability of its *)
(* software on equipment which is not supported by Stacken. *)
(* *)
(****************************************************************************)
(*$E+,T- *)
module buffer;
const
strsize = 40; (* universal string length *)
ctrlatsign = 0; (* null *)
ctrlj = 10; (* linefeed *)
LineFeed = 10; (* Fuck U, Red Baron! *)
ctrlm = 13; (* carriage return *)
null = ctrlatsign; (* null again *)
(*@VMS: DskSize = 512; *)
(*@TOPS: DskSize = 640; *)
chunksize = dsksize; (* which is also maximum size of a chunk *)
maxkillbuf= 8; (* number of kill buffers *)
save_corpse = true; (* mnemonics for murder procedure *)
dont_save_corpse = false;
answer = 42; (* the ultimate answer to the universe *)
type
bufpos = integer;
string = packed array[1..strsize] of char;
refchunk = ^textchunk; (* pointer to a text chunk *)
textchunk = packed array[1..chunksize] of char;
refcdc = ^cdc; (* pointer to a CDC *)
cdc = packed record (* Chunk Data Control-template *)
size: integer; (* number of chars in chunk *)
left,right: refcdc; (* links to other CDCs *)
tchunk: refchunk; (* pointer to the text *)
end;
chunkpos = record
chunk: refcdc; (* which chunk *)
pos: integer (* offset for character position *)
end;
refbuffer = ^bufferheader;
bufferheader = record
size: bufpos; (* buffer size *)
left,right: refbuffer;
number: integer; (* number used to refer to buffer *)
head: refcdc; (* actual header *)
dot: bufpos; (* current position *)
modified: boolean (* true if buffer has been modified *)
end;
(* Variable declarations *)
var
zbuf : refbuffer; (* pointer to buffer number 0 *)
maxbuf : integer; (* highest positive buffer number *)
minqreg : integer; (* lowest negative (Qreg) buffer number *)
cbuf : integer; (* index for current buffer *)
csize : integer; (* size of current buffer *)
chead : refcdc; (* head of current buffer *)
cdot : bufpos; (* the current position in the current buffer *)
cmodified : Boolean; (* true if the current buffer has been modified *)
coffin : integer; (* index for current kill buffer *)
cc : refcdc; (* pointer to CDC for the "current chunk" *)
icc : bufpos; (* buffer position of 1st char in current chunk *)
rvoid : refcdc; (* used to void refcdc-type values *)
gcc : refcdc; (* pointer to current "GC chunk" *)
gchead : refcdc; (* header for the buffer currently being GC:ed *)
gcbuf : refbuffer; (* pointer to the buffer currently being GC:ed *)
gcoff : boolean; (* true if GC should not be performed. *)
eol : string; (* string containing the end-of-line sequence *)
eolnp : array [1..strsize] of char; (* also unpacked, for speed. *)
eolcount : integer; (* length of end-of-line sequence *)
eollf : boolean; (* true if single line feed is eol too. *)
ExactCase : boolean; (* true if searches dont match upper and lower case *)
cdccache : refcdc; (* cdc cache. *)
(* External routines needed. Note: procedures wininsert, etc. begin *)
(* with "win" for historical reasons. *)
procedure wininsert(i: bufpos); external; (* from module SCREEN *)
procedure windelete(i: bufpos); external; (* from module SCREEN *)
procedure winsetdot(i: bufpos); external; (* from module SCREEN *)
procedure winbuf(n: integer); external; (* from module SCREEN *)
procedure error(s: string); external; (* from module MAIN *)
procedure bug(s: string); external; (* from module TTYIO *)
function upcase(c: char): char; external; (* from module AMILIB *)
function DownCase(c: char): char; external; (* from module AMILIB *)
function StrLength(s: string): integer; external;
(* The following routines make up the machine-dependent buffer handler *)
(* All of them come from sub-module MBUF *)
procedure movebytes(sc,dc: refchunk; si,di,count: integer); external;
function findchar(c1,c2: char; r: refchunk; pos,range: integer): integer;
external;
function bfindchar(c1,c2: char; r: refchunk; pos,range: integer): integer;
external;
(* Here it comes ... *)
(*--------------------------------------NIBERROR-----------------------------*)
procedure niberror;
begin
error('NIB? Character Not In Buffer ')
end;
(*--------------------------------------FINDBACKWARDS------------------------*)
procedure findbackwards(i: bufpos); (* findbackwards and findforward *)
(* move global variables cc and icc *)
(* to the chunk that contains the *)
(* character preceding i, or if i=0, *)
(* the dummy header chunk. If you *)
(* want the character following i *)
(* instead, do find...(i+1). *)
begin
if i<0 then bug('Findbackwards: argument out of range ');
repeat
cc:=cc^.left;
icc:=icc-cc^.size
until icc<i
end;
(*--------------------------------------FINDFORWARD--------------------------*)
procedure findforward(i: bufpos);
begin
if i>csize then bug('Findforward: argument out of range ');
icc:=icc+cc^.size;
repeat
cc:=cc^.right;
icc:=icc+cc^.size
until icc>=i;
icc:=icc-cc^.size
end;
(*--------------------------------------DELCHUNKS----------------------------*)
procedure delchunks(b,c: refcdc); (* Delete b-c from the buffer they *)
(* are in *)
var
a,z: refcdc;
begin
a:=b^.left;
z:=c^.right;
a^.right:=z; (* replace right link *)
z^.left:=a; (* replace left link *)
end;
(*--------------------------------------FREECHUNKS---------------------------*)
procedure freechunks(c1,c2: refcdc); (* Release the chunks from c1 to c2 *)
(* (inclusive), and put them in the *)
(* free list *)
label 1;
var
c3,c4: refcdc;
c3text: refchunk;
begin
c3:=c1; (* start with leftmost chunk *)
while true do begin
c4:=c3^.right; (* remember address of next chunk *)
c3text:=c3^.tchunk; (* required by compiler bug *)
if c3text<>nil then (* free text chunk if we have one *)
dispose(c3text);
dispose(c3); (* free the cdc itself *)
if c3=c2 then goto 1; (* quit when c2 is reached *)
c3:=c4 (* advance to next chunk *)
end;
1:
end;
(*--------------------------------------GCNEXTBUF----------------------------*)
procedure gcnextbuf; (* move to GC another buffer *)
begin
gcbuf:=gcbuf^.right;
gchead:=gcbuf^.head;
gcc:=gchead
end;
(*--------------------------------------GC-----------------------------------*)
procedure gc(protected: refcdc); (* Do a little garbage collecting *)
label 1,2;
var r,oldgcc: refcdc;
begin
if gcoff then goto 2; (* The GC may be off. *)
if gcbuf=zbuf then begin (* don't touch buffer 0 *)
gcnextbuf;
goto 2
end;
oldgcc:=gcc;
1: (* try to find some garbage *)
r:=gcc^.right;
if gcc^.size+r^.size>chunksize then begin
gcc:=r;
if gcc=gchead then gcnextbuf;
if (gcc=oldgcc) or (gcbuf=zbuf) then goto 2;
goto 1
end; (* found some. *)
if gcc<>cc then (* keep protected pointer and cc *)
if r<>cc then
if gcc<>protected then
if r<>protected then begin
movebytes(r^.tchunk,gcc^.tchunk,0,gcc^.size,r^.size);
gcc^.size:=gcc^.size+r^.size;
delchunks(r,r);
freechunks(r,r);
goto 2
end;
gcc:=r; if gcc<>oldgcc then goto 1;
2:
gcoff := false; (* Turn the GC back on. *)
end;
(*--------------------------------------NEWCDC-------------------------------*)
function newcdc: refcdc;
var
c: refcdc;
i: integer;
begin
if cdccache = nil
then for i := 1 to 30 do begin
new(c);
c^.right := cdccache;
cdccache := c;
end;
newcdc := cdccache;
cdccache := cdccache^.right;
end;
(*--------------------------------------CONSACHUNK---------------------------*)
function consachunk(protected: refcdc): refcdc; (* Cons a chunk *)
var
c: refcdc;
begin
gc(protected); (* release some garbage *)
c := newcdc; (* allocate a new cdc *)
new(c^.tchunk); (* allocate a new text chunk *)
consachunk:=c (* return constructed chunk *)
end;
(*--------------------------------------CONSABUFFER--------------------------*)
function consabuffer(protected: refcdc): refbuffer; (* Cons a buffer *)
var
b: refbuffer;
begin
gc(protected); (* release some garbage *)
new(b); (* allocate a new buffer *)
with b^ do begin
size:=0;
new(head); (* allocate a new head cdc *)
with head^ do begin
size:=chunksize; (* this makes other things easy *)
left:=head;
right:=head;
tchunk:=nil;
end
end;
consabuffer:=b (* return constructed buffer *)
end;
(*--------------------------------------INSCHUNKS----------------------------*)
procedure inschunks(a,b,c: refcdc); (* Insert b-c after a *)
var
z: refcdc;
begin
z:=a^.right;
a^.right:=b; (* change right link in a *)
b^.left:=a; (* change left link in b *)
z^.left:=c; (* change left link in z *)
c^.right:=z (* change right link in c *)
end;
(*--------------------------------------INSBUFFERS---------------------------*)
procedure insbuffers(a,b,c: refbuffer); (* Insert b-c after a *)
var
z: refbuffer;
begin
z:=a^.right;
a^.right:=b; (* change right link in a *)
b^.left:=a; (* change left link in b *)
z^.left:=c; (* change left link in z *)
c^.right:=z (* change right link in c *)
end;
(*--------------------------------------FINDBUFFER---------------------------*)
function findbuffer(n: integer): refbuffer; (* Finds buffer in linked list *)
var
b,c: refbuffer;
begin
b:=nil;
c:=zbuf^.right; (* scan forward from buffer 0 *)
while (b=nil) and (c<>zbuf) do (* until we find buffer or buffer 0 *)
if c^.number=n then
b:=c
else
c:=c^.right;
if b=nil then (* we didn't find the buffer, so ... *)
if n<0 then begin (* ... create it, if it is internal *)
b:=consabuffer(nil);
b^.number:=n;
insbuffers(zbuf^.left,b,b)
end
else (* ... bug, if request from MAIN *)
bug('Findbuffer: Buffer not found! ');
findbuffer:=b
end;
(*--------------------------------------COPY---------------------------------*)
procedure copy(source,dest: chunkpos; count: integer);
(* Copy count characters from source *)
(* to dest *)
begin
movebytes(source.chunk^.tchunk,dest.chunk^.tchunk,source.pos,dest.pos,count)
end;
(*--------------------------------------GETPOS-------------------------------*)
procedure getpos(var x: chunkpos; i: bufpos);
(* x := chunkpos corresponding to i *)
var j: integer;
begin
j:=i-icc;
if j<1 then begin (* before current chunk? *)
findbackwards(i);
j:=i-icc;
end
else
if j>cc^.size then begin (* after current chunk? *)
findforward(i);
j:=i-icc
end;
x.chunk:=cc;
x.pos:=j
end;
(*--------------------------------------MAKEHOLE-----------------------------*)
function makehole(p: chunkpos): refcdc; (* Make a hole here. Return the *)
(* right link of p.chunk *)
var
n: integer;
q: chunkpos;
pp: refcdc;
begin
pp:=p.chunk;
n:=pp^.size-p.pos;
if n=0 then begin (* maybe we don't need any hole? *)
makehole:=pp^.right;
end
else begin
with q do begin
chunk:=consachunk(pp); (* construct a chunk *)
pos:=0;
copy(p,q,n); (* put text in it *)
chunk^.size:=n; (* set the size *)
pp^.size:=p.pos; (* delete the copied text *)
inschunks(pp,chunk,chunk); (* now insert the new chunk *)
makehole:=chunk
end
end
end;
(*--------------------------------------FINDREGION---------------------------*)
procedure findregion(var a,b: bufpos; i: bufpos);
(* a:= min(cdot,cdot+i); *)
begin (* b:= max(cdot,cdot+i) *)
if i<0 then begin
a:=cdot+i; b:=cdot
end
else begin
a:=cdot; b:=cdot+i
end;
if a<0 then niberror
else
if b>csize then niberror
end;
(*--------------------------------------MURDER-------------------------------*)
procedure murder(i: bufpos; save_corpsep: Boolean);
(* Delete all characters between *)
(* dot and dot+i (i may be < 0). *)
(* If save_corpsep is true, the *)
(* deleted string will be inserted *)
(* at the end of the current kill *)
(* buffer. *)
var
a,b,n,oldicc: bufpos;
aa,bb: chunkpos;
x,y: refcdc;
k: refbuffer;
begin
if i<>0 then begin
findregion(a,b,i);
n:=b-a;
if a<0 then niberror (* (take away these tests later?) *)
else
if b>csize then niberror
else begin
cdot:=a;
winsetdot(cdot); (* prepare SCREEN for the slaughter *)
getpos(bb,b);
y:=bb.chunk;
if (bb.pos>=n) and (y^.size>n) and not save_corpsep
then begin
aa.chunk:=y; (* delete part of chunk *)
aa.pos:=bb.pos-n;
copy(bb,aa,y^.size-bb.pos); (* move down rest of chunk *)
y^.size:=y^.size-n
end
else begin
getpos(aa,a);
x:=makehole(aa); (* x := right part of hole at a *)
oldicc:=icc;
getpos(bb,b);
cc:=aa.chunk; icc:=oldicc; (* trick to protect cc *)
y:=makehole(bb); (* y := right part of hole at b *)
if gchead=chead then gcc:=y;
y:=y^.left;
delchunks(x,y); (* delete chunks from buffer *)
if save_corpsep then begin
k:=findbuffer(-coffin-41); (* find kill buffer *)
with k^ do begin
if i>0 then (* append corpse to kill buffer *)
inschunks(head^.left,x,y)
else
inschunks(head,x,y); (* prepend instead *)
size:=size+n (* increment kill buffer size *)
end
end
else freechunks(x,y) (* release the corpse *)
end;
csize:=csize-n; (* decrement buffer size *)
cmodified:=true;
windelete(n) (* now let SCREEN do its share *)
end
end
end;
(*--------------------------------------RCLBUF-------------------------------*)
procedure rclbuf(n: integer); (* "Recall" buffer n *)
(* Make it the current one *)
var
b: refbuffer;
begin
b:=findbuffer(n);
with b^ do begin
csize:=size;
cdot:=dot;
cmodified:=modified;
chead:=head
end;
cbuf:=n;
cc:=chead;
icc:=-chunksize
end;
(*--------------------------------------STOBUF-------------------------------*)
procedure stobuf(n: integer); (* Store current buffer in buffer n *)
var
b: refbuffer;
begin
b:=findbuffer(n);
with b^ do begin
size:=csize;
head:=chead;
dot:=cdot;
modified:=cmodified
end
end;
(*--------------------------------------COPYBUFFER---------------------------*)
procedure copybuffer(buf: refbuffer);
(* Insert a copy of buf at dot *)
var
p: chunkpos;
s: bufpos;
x,newchk,pp: refcdc;
begin
if buf^.size>0 then begin
getpos(p,cdot);
rvoid:=makehole(p);
pp:=p.chunk;
x:=buf^.head;
s:=0;
repeat
x:=x^.left; (* go from right to left *)
newchk:=consachunk(x);
movebytes(x^.tchunk,newchk^.tchunk,0,0,x^.size);
inschunks(pp,newchk,newchk);
newchk^.size:=x^.size;
s:=s+newchk^.size;
until x=buf^.head^.right; (* reached last chunk? *)
csize:=csize+s;
cmodified:=true;
wininsert(s);
cdot:=cdot+s
end
end;
(*--------------------------------------CLEARBUFFER--------------------------*)
procedure clearbuffer(buf: refbuffer); (* Empties buf *)
var first,last: refcdc;
begin
with buf^ do begin
if size>0 then begin
if gchead=head then gcnextbuf;
first:=head^.right;
last:=head^.left;
delchunks(first,last);
size:=0;
freechunks(first,last)
end
end
end;
(*--------------------------------------OKGETCHAR----------------------------*)
function okgetchar(var c: char; i: bufpos): Boolean;
(* Put the i+1th character of the *)
label 1,2; (* current buffer in c, and return *)
var j: integer; (* if it is in range *)
begin
j:=i-icc;
if i<0 then goto 1; (* i outside buffer *)
if j<0 then begin (* before current chunk? *)
findbackwards(i+1);
c:=cc^.tchunk^[i-icc+1]
end
else
if j>=cc^.size then begin (* after current chunk? *)
if i>=csize then goto 1; (* i outside buffer *)
findforward(i+1);
c:=cc^.tchunk^[i-icc+1]
end
else c:=cc^.tchunk^[j+1]; (* in current chunk! *)
okgetchar:=true;
goto 2;
1:okgetchar:=false;
2:
end;
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(* *)
(* The following are the entry-point routines *)
(* *)
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(*--------------------------------------BufFlags-----------------------------*)
(*@VMS: [global] *)
procedure BufFlags(flags: string);
var c: char;
begin
c := flags[3]; (* "Display LineFeed as EOL" *)
if c = '-' then eollf := false;
if c = '+' then eollf := true;
c := flags[8]; (* "Case sensitive search" *)
if c = '-' then ExactCase := false;
if c = '+' then ExactCase := true;
end;
(*--------------------------------------BUFINIT------------------------------*)
(*@VMS: [global] *)
procedure bufinit; (* Initialize everything *)
begin
eol[1]:=chr(ctrlm); (* init eol string *)
eol[2]:=chr(ctrlj);
eolnp[1]:=chr(ctrlm);
eolnp[2]:=chr(ctrlj);
eolcount:=2;
eollf:=false;
ExactCase:=false;
coffin:=0; (* init kill ring pointer *)
cbuf:=0; (* no buffer in use yet *)
maxbuf:=0; (* highest buffer in use *)
minqreg:=-48; (* lowest allocated Qreg number *)
new(zbuf); (* create and initialize buffer 0 *)
with zbuf^ do begin
size:=-1;
left:=zbuf;
right:=zbuf;
number:=0;
head:=nil;
dot:=-1
end;
cdccache := nil; (* cdc cache is empty now. *)
gcbuf:=zbuf; (* The four statements moved into this *)
gchead:=gcbuf^.head; (* position is the former routine *)
gcc:=gchead; (* "GCINIT". *)
gcoff := false; (* The GC is normally on. *)
end;
(*--------------------------------------ISETBUF------------------------------*)
(*@VMS: [global] *)
procedure isetbuf(n: integer); (* invisibly choose buffer n *)
begin
if cbuf<>0 then
stobuf(cbuf);
rclbuf(n)
end;
(*--------------------------------------SETBUF-------------------------------*)
(*@VMS: [global] *)
procedure setbuf(n: integer); (* choose buffer n *)
begin
isetbuf(n);
winbuf(cbuf)
end;
(*--------------------------------------GETBUF-------------------------------*)
(*@VMS: [global] *)
function getbuf: integer; (* return number of current buffer *)
begin
getbuf:=cbuf
end;
(*--------------------------------------KILLBUF------------------------------*)
(*@VMS: [global] *)
procedure killbuf(n: integer); (* kills buffer n *)
var
b: refbuffer;
c: refcdc;
begin
if n<1 then
bug('Killbuf: Invalid buffer number ');
if cbuf<>0 then
stobuf(cbuf);
b:=findbuffer(n);
clearbuffer(b);
b^.right^.left:=b^.left; (* remove buffer from linked list *)
b^.left^.right:=b^.right;
c:=b^.head; (* required by compiler bug *)
dispose(c); (* free head cdc block *)
dispose(b); (* free buffer block itself *)
if cbuf<>0 then
rclbuf(cbuf)
end;
(*--------------------------------------CREATEBUF----------------------------*)
(*@VMS: [global] *)
function createbuf: integer; (* Create a new buffer and return *)
(* number *)
var
b: refbuffer;
begin
b:=consabuffer(nil); (* create a buffer *)
maxbuf:=maxbuf+1; (* increment max buffer number *)
with b^ do begin
number:=maxbuf; (* save buffer number *)
dot:=0;
modified:=false
end;
insbuffers(zbuf,b,b); (* insert buffer into linked list *)
createbuf:=maxbuf (* return buffer number *)
end;
(*--------------------------------------INSERT-------------------------------*)
(*@VMS: [global] *)
procedure insert(c: char); (* Insert c at dot *)
var
p,q: chunkpos;
x: refcdc;
begin
getpos(p,cdot);
with p do begin
if chunk^.size=chunksize then begin
rvoid:=makehole(p); (* chunk full? - then split it *)
if chunk^.size=chunksize then
begin (* hack that forces consing when *)
x:=consachunk(nil); (* makehole refuses to do so *)
x^.size:=0;
inschunks(chunk,x,x);
chunk:=x;
pos:=0
end
end
else if pos<chunk^.size then begin
q.chunk:=chunk; q.pos:=pos+1; (* make room for an extra char *)
copy(p,q,chunk^.size-pos)
end;
chunk^.tchunk^[pos+1] := c; (* store character in hole *)
chunk^.size:=chunk^.size+1 (* increment chunk size *)
end;
csize:=csize+1; (* increment buffer size *)
cmodified:=true; (* buffer has been modified *)
wininsert(1); (* tell SCREEN to insert the char *)
cdot:=cdot+1
end;
(*---------------------------------------------------------------------------*)
(*@VMS: [global] *)
procedure NInsert(c: char; n: integer);
var
i: integer;
begin
for i := 1 to n do Insert(c);
end;
(*---------------------------------------------------------------------------*)
(*@VMS: [global] *)
procedure InsString(Str: string);
var
Pos: integer;
begin
for Pos := 1 to StrLength(Str) do insert(Str[Pos])
end;
(*--------------------------------------RPLACHAR-----------------------------*)
(*@VMS: [global] *)
procedure rplachar(c: char); (* Replace the character after dot *)
var p: chunkpos;
begin
if cdot=csize then
bug('Rplachar: Dot at end of buffer ');
getpos(p,cdot+1);
with p do chunk^.tchunk^[pos] := c;
cmodified:=true;
windelete(1);
wininsert(1); cdot:=cdot+1
end;
(*--------------------------------------DELETE-------------------------------*)
(*@VMS: [global] *)
procedure delete(i: bufpos); (* Delete i characters after dot *)
begin
murder(i,dont_save_corpse)
end;
(*--------------------------------------KILL---------------------------------*)
(*@VMS: [global] *)
procedure kill(i: bufpos); (* Delete i characters after dot and *)
(* append to the current kill buffer *)
begin
murder(i,save_corpse)
end;
(*--------------------------------------KILLPUSH-----------------------------*)
(*@VMS: [global] *)
procedure killpush; (* select a new, empty kill buffer *)
var
k: refbuffer;
begin
coffin:=(coffin+1) mod maxkillbuf;
k:=findbuffer(-coffin-41);
clearbuffer(k)
end;
(*--------------------------------------UNKILL-------------------------------*)
(*@VMS: [global] *)
procedure unkill(n: integer); (* Insert a copy of the n:th kill *)
(* buffer (the most recent is 1) *)
var index : integer; (* after dot. *)
begin
index:=(coffin-n+1) mod maxkillbuf; (* I have to use a temporary *)
if index<0 then (* Index gets negative if n>coffin *)
index:=index+maxkillbuf; (* on some computers. *)
copybuffer(findbuffer(-index-41)) (* variable here, because our Humbug *)
end; (* Pascal compiler refuses to *)
(* generate the right code otherwise *)
(*--------------------------------------UNK2STRING---------------------------*)
(*@VMS: [global] *)
procedure Unk2String(var Line: string; var Pos: integer);
var
currentBuffer: integer;
c: char;
i: integer;
begin
CurrentBuffer := cbuf;
isetbuf(-41-coffin);
i := 0;
while (Pos < StrSize) and okgetchar(c,i)
do begin
Line[Pos] := c;
Pos := Pos + 1;
i := i + 1;
end;
isetbuf(CurrentBuffer);
end;
(*--------------------------------------KILLPOP------------------------------*)
(*@VMS: [global] *)
procedure killpop; (* Pops the kill ring one step *)
begin
coffin:=(coffin+maxkillbuf-1) mod maxkillbuf
end;
(*--------------------------------------QX-----------------------------------*)
(*@VMS: [global] *)
procedure qx(qreg: integer; i: bufpos); (* Put text in Q-register *)
var
a,b: bufpos;
n: integer;
q: refbuffer;
pp: chunkpos;
x: refcdc;
begin
q:=findbuffer(qreg);
clearbuffer(q);
if i<>0 then begin
findregion(a,b,i);
repeat
getpos(pp,a+1); pp.pos:=pp.pos-1;
x:=consachunk(nil);
with pp do begin
n:=chunk^.size-pos;
if n>b-a then n:=b-a; (* n:= min(n,b-a) *)
movebytes(chunk^.tchunk,x^.tchunk,pos,0,n);
end;
x^.size:=n;
with q^ do begin
inschunks(head^.left,x,x); (* put text in Q-reg. buffer *)
size:=size+n
end;
a:=a+n
until a=b
end
end;
(*--------------------------------------QG-----------------------------------*)
(*@VMS: [global] *)
procedure qg(qreg: integer); (* Get Q-register *)
var
b: refbuffer;
begin
b:=findbuffer(qreg);
copybuffer(b)
end;
(*--------------------------------------GETDOT-------------------------------*)
(*@VMS: [global] *)
function getdot: bufpos; (* Return the value of dot *)
begin
getdot:=cdot
end;
(*--------------------------------------SETDOT-------------------------------*)
(*@VMS: [global] *)
procedure setdot(i: bufpos); (* Set dot to i *)
begin
if (i<0) or (i>csize) then niberror (* check range of argument *)
else begin
cdot:=i;
winsetdot(cdot) (* tell SCREEN about it *)
end
end;
(*--------------------------------------GETSIZE------------------------------*)
(*@VMS: [global] *)
function getsize: bufpos; (* Returns size of buffer *)
begin
getsize:=csize
end;
(*--------------------------------------GETCHAR------------------------------*)
(*@VMS: [global] *)
function getchar(i: bufpos): char; (* Return the i+1th character of the *)
(* current buffer *)
var c: char;
begin
if okgetchar(c,i) then getchar:=c
else niberror
end;
(*--------------------------------------GETNULL------------------------------*)
(*@VMS: [global] *)
function getnull(i: bufpos): char; (* Like getchar, but returns null if *)
(* argument is out of range *)
var c: char;
begin
if okgetchar(c,i) then getnull:=c
else getnull:=chr(null)
end;
(*--------------------------------------BGETCHAR-----------------------------*)
(*@VMS: [global] *)
function bgetchar(i: bufpos): char; (* Like getchar, but bug if argument *)
(* out of range *)
var c: char;
begin
if okgetchar(c,i) then bgetchar:=c
else
bug('Bgetchar: argument out of range ')
end;
(*--------------------------------------INSBLOCK-----------------------------*)
(*@VMS: [global] *)
procedure insblock(s: refchunk; c: integer);
(* Insert c characters from the disk *)
(* block s at dot *)
var p: chunkpos; x: refcdc;
begin
getpos(p,cdot);
rvoid:=makehole(p);
gcoff := true; (* Inhibit GC on this call to consachunk. *)
x:=consachunk(nil); (* cons a new chunk to put chars in *)
x^.size:=c;
inschunks(p.chunk,x,x);
movebytes(s,x^.tchunk,0,0,c); (* transfer the characters *)
csize:=csize+c;
cmodified:=true;
wininsert(c);
cdot:=cdot+c
end;
(*--------------------------------------GETBLOCK-----------------------------*)
(*@VMS: [global] *)
procedure getblock(p: bufpos; d: refchunk);
(* Fill the disk block d with chars *)
(* from buffer position p *)
label 1;
var
i: bufpos; pp: chunkpos;
s,n: integer;
begin
i:=p; (* start at p *)
s:=dsksize; (* s = no. of chars to write *)
repeat
if i=csize then goto 1; (* quit at end of buffer *)
getpos(pp,i+1);
with pp do begin
pos:=pos-1;
n:=chunk^.size-pos; (* remaining chars in this chunk *)
if n>s then n:=s; (* n:= min(n,s) *)
movebytes(chunk^.tchunk,d,pos,dsksize-s,n);
s:=s-n;
i:=i+n
end
until s=0;
1:
end;
(*--------------------------------------BUFSEARCH----------------------------*)
(*@VMS: [global] *)
function bufsearch(s: string; len, arg: integer; n: bufpos): Boolean;
(* Search for the argth occurence of *)
(* string s of length len, between *)
(* dot and dot+n (n=0 => to end of *)
(* buffer). Search backwards if arg *)
(* is negative. If succesful, place *)
(* dot immediately AFTER the match, *)
(* and return true. Otherwise return *)
(* false and don't move dot. *)
label 1,2,3,4,5;
var
ch : char;
upper,lower : array[1..strsize] of char;
stop : bufpos;
sdot,oldsdot : bufpos;
i,k,count : integer;
spos,pos,inc : integer;
dummy : chunkpos;
begin
if len>strsize then bug('Bufsearch: String length too large ');
if len<=0 then goto 4;
if arg=0 then bug('Bufsearch: Aaaarrrrrrrrrgggghhh = 0 ');
for i:=1 to len do begin
ch := s[i];
if ExactCase then begin
upper[i] := ch;
lower[i] := ch;
end else begin
upper[i] := UpCase(ch);
lower[i] := DownCase(ch)
end;
end;
count:=arg;
sdot:=cdot;
oldsdot:=-1;
if arg>0 then
begin (* ----- Search Forward ----- *)
spos:=0;
stop:=csize;
if n>0 then
if cdot+n<csize then
stop:=cdot+n;
repeat
if sdot=stop then goto 4;
getpos(dummy,sdot+1);
repeat
spos:=spos+1;
while true do begin (* look for s[spos] *)
pos:=sdot-icc;
k:=cc^.size-pos;
if k>stop-sdot then k:=stop-sdot;
inc:=findchar(upper[spos],lower[spos],cc^.tchunk,pos,k);
if inc>0 then goto 1;
with cc^ do begin (* go to next chunk *)
icc:=icc+size;
sdot:=icc;
if sdot>=stop then begin
icc:=icc-size;
goto 4 (* lose *)
end;
cc:=right;
end
end;
1:
sdot:=sdot+inc
until spos=len; (* have we found all characters? *)
if sdot=oldsdot then begin
count:=count-1; (* count down arg *)
if count=0 then goto 3; (* Win! *)
sdot:=sdot-len+1 (* go for next match *)
end
else begin (* possible win... *)
oldsdot:=sdot;
sdot:=sdot-len
end;
spos:=0
until false
end
else
begin (* ----- Search Backwards ----- *)
spos:=len;
repeat
if sdot=0 then goto 4;
getpos(dummy,sdot);
repeat
while true do begin (* look for s[spos] *)
pos:=sdot-icc;
inc:=bfindchar(upper[spos],lower[spos],cc^.tchunk,pos,pos);
if inc>0 then goto 2;
sdot:=icc;
if sdot=0 then goto 4; (* lose *)
cc:=cc^.left;
icc:=icc-cc^.size;
end;
2:
sdot:=sdot-inc;
spos:=spos-1;
until spos=0; (* found all chars? *)
if sdot=oldsdot then begin
count:=count+1; (* count up (!) arg *)
sdot:=sdot+len;
if count=0 then goto 3; (* Win! *)
sdot:=sdot-1 (* ??? *)
end
else begin
oldsdot:=sdot;
sdot:=sdot+len
end;
spos:=len
until false
end;
3:cdot:=sdot; (* winning exit *)
winsetdot(cdot);
bufsearch:=true;
goto 5;
4:bufsearch:=false; (* losing exit *)
5:
end;
(*--------------------------------------EOLSIZE------------------------------*)
(*@VMS: [global] *)
function eolsize: integer;
begin
eolsize:=eolcount
end;
(*--------------------------------------ATEOL--------------------------------*)
(* True if end-of-line follows (d>0) or precedes (d<0) i *)
(*@VMS: [global] *)
function ateol(i: bufpos; d: integer): Boolean;
label 1;
var j: integer;
begin
ateol:=false;
if d>0 then begin
if eollf then begin
if i >= csize then goto 1;
if bgetchar(i) = chr(LineFeed) then begin
ateol := true; goto 1;
end;
end;
if i>csize-eolcount then goto 1; (* Too near end of buffer *)
for j:=1 to eolcount do
if bgetchar(i+j-1)<>eolnp[j] then goto 1;
ateol:=true
end else if d<0 then begin
if eollf then begin
if i < 1 then goto 1;
if bgetchar(i-1) = chr(LineFeed) then begin
ateol := true; goto 1;
end;
end;
if i<eolcount then goto 1; (* Too near start of buffer *)
for j:=1 to eolcount do
if bgetchar(i+j-1-eolcount)<>eolnp[j] then goto 1;
ateol:=true
end;
1:
end;
(*--------------------------------------INSEOL-------------------------------*)
(*@VMS: [global] *)
procedure inseol; (* insert an end-of-line string *)
var i: integer;
begin
for i:=1 to eolcount do insert(eolnp[i])
end;
(*--------------------------------------EOLSTRING----------------------------*)
(*@VMS: [global] *)
procedure eolstring(var s: string; var l: integer);
(* Return end of line string and its *)
(* length *)
begin
s:=eol;
l:=eolcount
end;
(*--------------------------------------GETLINE------------------------------*)
(*@VMS: [global] *)
function getline(i: integer): bufpos; (* Return the position of the *)
(* beginning of the ith line *)
(* following the line dot is in. *)
(* Negative i means lines above this *)
(* one, i=0 means this line *)
var oldcdot: bufpos;
begin
oldcdot:=cdot;
if i>0 then begin
if cdot>0 then cdot:=cdot-1;
if not bufsearch(eol,eolcount,i,0) then
cdot:=csize
end
else begin
if not bufsearch(eol,eolcount,i-1,0) then
cdot:=0
end;
getline:=cdot;
cdot:=oldcdot;
winsetdot(cdot)
end;
(*--------------------------------------ENDLINE------------------------------*)
(*@VMS: [global] *)
function endline: bufpos; (* Return the position of the end *)
(* of the current line *)
var oldcdot: bufpos;
begin
oldcdot:=cdot;
if cdot>0 then cdot:=cdot-1;
if bufsearch(eol,eolcount,1,0) then begin
endline:=cdot-eolcount;
winsetdot(oldcdot)
end
else
endline:=csize;
cdot:=oldcdot
end;
(*--------------------------------------GETMODIFIED--------------------------*)
(*@VMS: [global] *)
function getmodified: Boolean; (* Find out if the buffer *)
(* has been modified *)
begin
getmodified:=cmodified
end;
(*--------------------------------------SETMODIFIED--------------------------*)
(*@VMS: [global] *)
procedure setmodified(v: Boolean); (* Set or clear modflag *)
begin
cmodified:=v
end;
(*--------------------------------------SWAPREGIONS--------------------------*)
(*@VMS: [global] *)
procedure swapregions(i1,i2,i3,i4: bufpos); (* Swap regions. *)
var
nogood: Boolean;
oldcoffin: integer;
oldcdot: bufpos;
b4711: refbuffer;
n1,n2: bufpos;
jb1,je1,jb2,je2: bufpos;
b1,e1,b2,e2: chunkpos;
start1,start2: refcdc;
procedure sort(var x,y: bufpos); (* sort x & y ascending *)
var tmp: bufpos;
begin
if x>y then begin
tmp:=x; x:=y; y:=tmp; (* exchange x & y *)
nogood:=true
end
end;
begin
jb1:=i1; je1:=i2; jb2:=i3; je2:=i4;
nogood:=true; (* sort jb1,je1,jb2,je2 ascending *)
while nogood do begin
nogood:=false;
sort(jb1,je1);
sort(je1,jb2);
sort(jb2,je2)
end;
if (jb1<0) or (je2>csize) then
bug('Swapregions: argument out of range ');
n1:=je1-jb1; (* length of 1st region *)
n2:=je2-jb2; (* length of 2nd region *)
oldcdot:=cdot;
setdot(jb1);
(* WARNING! Ugly hack follows. Sensitive persons close their eyes! *)
oldcoffin:=coffin;
coffin:=4711; (* a non-existent kill buffer! *)
kill(n1); (* kill 1st region *)
setdot(jb2-n1);
b4711:=findbuffer(-4752); (* GAAAAAKKKKK!!!!!! *)
copybuffer(b4711); (* unkill it *)
clearbuffer(b4711);
setdot(jb2);
kill(n2); (* kill 2nd region *)
setdot(jb1);
copybuffer(b4711); (* unkill it *)
clearbuffer(b4711);
coffin:=oldcoffin;
setdot(oldcdot)
end;
(*--------------------------------------QCOPY--------------------------------*)
(*@VMS: [global] *)
procedure qcopy(qfrom, qto: integer); (* Copy a Q register *)
var
source, dest: refbuffer;
x, newchk: refcdc;
begin
stobuf(cbuf); (* uncache variables... *)
source:=findbuffer(qfrom);
dest:=findbuffer(qto);
clearbuffer(dest);
(* The following code is almost the same as in Copybuffer. *)
(* Someday there will be a common copying procedure... *)
if source^.size>0 then begin
x:=source^.head;
with dest^ do begin
repeat
x:=x^.left; (* go from left to right *)
newchk:=consachunk(x);
movebytes(x^.tchunk,newchk^.tchunk,0,0,x^.size);
inschunks(head,newchk,newchk);
newchk^.size:=x^.size;
size:=size+newchk^.size
until x=source^.head^.right (* reached last chunk? *)
end
end
end;
(*--------------------------------------QCREATE------------------------------*)
(*@VMS: [global] *)
function qcreate: integer; (* Create a new Qreg and return *)
(* number *)
var
b: refbuffer;
begin
b:=consabuffer(nil); (* create a buffer *)
minqreg:=minqreg-1; (* decrement min Qreg number *)
with b^ do begin
number:=minqreg; (* save buffer number *)
dot:=0;
modified:=false
end;
insbuffers(zbuf,b,b); (* insert buffer into linked list *)
qcreate:=minqreg (* return buffer number *)
end;
(*--------------------------------------QGETSIZE-----------------------------*)
(*@VMS: [global] *)
function qgetsize(qreg: integer): integer; (* Obtain size of Qreg *)
var cretin: refbuffer;
begin
cretin:=findbuffer(qreg);
qgetsize:=cretin^.size
end;
(*--------------------------------------QGETDOT------------------------------*)
(*@VMS: [global] *)
function qgetdot(qreg: integer): integer; (* Obtain dot of Qreg *)
var cretin: refbuffer;
begin
cretin:=findbuffer(qreg);
qgetdot:=cretin^.dot
end;
(*--------------------------------------QSETDOT------------------------------*)
(*@VMS: [global] *)
procedure qsetdot(qreg: integer; i: bufpos); (* Set Qreg dot *)
var cretin: refbuffer;
begin
cretin:=findbuffer(qreg);
with cretin^ do
if (i<0) or (i>size) then
bug('QSetDot: dot out of range. ')
else dot:=i
end;
(*--------------------------------------QINSERT------------------------------*)
(*@VMS: [global] *)
procedure qinsert(qreg: integer; c: char);
var thisbuf: integer;
begin
thisbuf:=cbuf;
isetbuf(qreg);
insert(c);
isetbuf(thisbuf)
end;
(*--------------------------------------QDELETE------------------------------*)
(*@VMS: [global] *)
procedure qdelete(qreg: integer; i: bufpos);
var thisbuf: integer;
begin
thisbuf:=cbuf;
setbuf(qreg);
delete(i);
setbuf(thisbuf)
end;
(*--------------------------------------QGETCHAR-----------------------------*)
(*@VMS: [global] *)
function qgetchar(qreg: integer; i: bufpos): char;
var thisbuf: integer; c: char;
begin
thisbuf:=cbuf;
isetbuf(qreg);
if okgetchar(c,i) then qgetchar:=c
else bug('QGetChar: argument out of range ');
isetbuf(thisbuf)
end;
(*--------------------------------------MAIN---------------------------------*)
(*@TOPS: begin end. *)
(*@VMS: end. *)