mirror of
https://github.com/PDP-10/stacken.git
synced 2026-01-31 05:42:03 +00:00
1496 lines
40 KiB
ObjectPascal
1496 lines
40 KiB
ObjectPascal
(* 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. *)
|