-- File DJExtMerge.mesa
-- Written by Martin Newell, June 1981
-- Last updated: July 24, 1981 3:08 PM

DIRECTORY

crD: FROM "CoreDefs" USING [CloseFile, OpenFile, PageNumber, ReadPages, UFileHandle, UFileTruncate, WritePages],
InlineDefs: FROM "InlineDefs" USING[BITAND, BITSHIFT],
DJExtMergeDefs: FROM "DJExtMergeDefs",
DJExtTypes: FROM "DJExtTypes" USING [NodeNumber],
MiscDefs: FROM "MiscDefs" USING [CallDebugger, Zero],
Mopcodes: FROM "Mopcodes" USING [zEXCH, zPOP],
ovD: FROM "OverviewDefs" USING [ErrorCode, ok],
--SegmentDefs: FROM "SegmentDefs" USING [NewFile, Read, OldFileOnly, DestroyFile],
StringDefs: FROM "StringDefs" USING [AppendString],
SystemDefs: FROM "SystemDefs" USING [AllocateResidentPages, FreePages];

DJExtMerge: PROGRAM
IMPORTS crD, InlineDefs, MiscDefs, StringDefs, SystemDefs
EXPORTS DJExtMergeDefs =

BEGIN OPEN crD, InlineDefs, DJExtTypes, MiscDefs, Mopcodes, ovD, StringDefs, SystemDefs;


InitMerge: PUBLIC PROCEDURE [] =
-- Initialize merge to use file fileName
BEGIN
GenValue ← ZeroValue;
SmallValue ← ZeroValue;
OpenMergeFile["merge.tmp$"];
END;

ConsolidateMerge: PUBLIC PROCEDURE =
BEGIN
END;

FinishMerge: PUBLIC PROCEDURE =
-- Close files and release structures
BEGIN
CloseMergeFile[];
END;

GenNodeNumber: PUBLIC PROCEDURE RETURNS[n: NodeNumber] =
--Generate new Merge value
BEGIN
RETURN[GenValue ← GenValue + 1];
END;

ReserveNodeNumbers: PUBLIC PROCEDURE [n: NodeNumber] =
BEGIN
GenValue ← GenValue + n;
END;

Merge: PUBLIC PROCEDURE [n1,n2: NodeNumber] RETURNS[r: NodeNumber] =
--Merge numbers n1 and n2 towards smaller of the two
--Returns resulting value of Lookup[n1] (=Lookup[n2])
BEGIN
r1,r2: NodeNumber;
n1buff,n2buff,r1buff,r2buff: CARDINAL;
IF n1 = 0 OR n2 = 0 THEN CallDebugger["Merge called with 0"];
IF n1 = n2 THEN RETURN[n1];
n1buff ← Lock[n1,0];
n2buff ← Lock[n2,0];
--find roots, r1,r2 of n1,n2
[r1,r1buff] ← IntLookup[n1,n1buff];
[] ← Lock[r1,r1buff];
[r2,r2buff] ← IntLookup[n2,n2buff];
[] ← Lock[r2,r2buff];
--merge roots
--new root is min of r1 and r2
IF LessThan[r1,r2] THEN
BEGIN
r ← r1;
[] ← SetValue[r2,r2buff,r];
END
ELSE
BEGIN
r ← r2;
[] ← SetValue[r1,r1buff,r];
END;
--shorten paths from n1 and n2 to new root
[] ← SetValue[n1,n1buff,r];
[] ← SetValue[n2,n2buff,r];
UnlockAll[];
END;

Lookup: PUBLIC PROCEDURE[n: NodeNumber]
RETURNS[r: NodeNumber] =
--Return smallest number to which n has been merged, transitively closed
BEGIN
nbuff: CARDINAL;
IF n = 0 THEN CallDebugger["Lookup called with 0"];
nbuff ← Lock[n,0];
r ← IntLookup[n,nbuff].r;
Unlock[nbuff];
END;

LookSmall: PUBLIC PROCEDURE[n: NodeNumber]
RETURNS[r: NodeNumber] =
--Return smallest number it can assign to n
BEGIN
nbuff: CARDINAL;
IF n = 0 THEN CallDebugger["LookSmall called with 0"];
nbuff ← Lock[n,0];
r ← IntLookup2[n,nbuff].r;
Unlock[nbuff];
END;

GetSmall: PUBLIC PROCEDURE RETURNS[NodeNumber] =
--Return smallest number assigned
BEGIN
RETURN[SmallValue];
END;

IsSmall: PUBLIC PROCEDURE[n: NodeNumber] RETURNS[BOOLEAN] =
--Return true if it has been assigned a small number
BEGIN
r,t: NodeNumber;
rbuff,nbuff: CARDINAL;
flag: BOOLEAN ← FALSE;
IF n = 0 THEN CallDebugger["IsSmall called with 0"];
nbuff ← Lock[n,0];
--find root, r, of n
[t,nbuff,flag] ← GetValue[n,nbuff];
r ← n;
rbuff ← nbuff;
UNTIL flag OR t = r DO
r ← t;
[t,rbuff,flag] ← GetValue[r,rbuff]; --rbuff is only a hint on rhs
ENDLOOP;
Unlock[nbuff];
RETURN[flag];
END;

PutProp: PUBLIC PROCEDURE[n: NodeNumber, prop:LONG UNSPECIFIED] =
--attach prop to node number n
BEGIN
vptr: POINTER TO NodeNumber;
npage,noffset: CARDINAL;
realnbuff: CARDINAL;
nbuff: CARDINAL ← Lock[n,0];
[npage,noffset] ← PageAddress[n];
realnbuff ← GetPage[npage,nbuff];
vptr ← BufferTable[realnbuff].buffer + noffset + SIZE[NodeNumber];
IF vptr↑#prop THEN --avoid setting .dirty if possible
BEGIN
vptr↑ ← prop;
BufferTable[realnbuff].dirty ← TRUE;
END;
Unlock[nbuff];
END;

GetProp: PUBLIC PROCEDURE[n: NodeNumber] RETURNS[LONG UNSPECIFIED] =
--get the prop that has been attached to n.
BEGIN
vptr: POINTER TO NodeNumber;
npage,noffset: CARDINAL;
realnbuff: CARDINAL;
v: LONG POINTER TO UNSPECIFIED;
nbuff: CARDINAL ← Lock[n,0];
[npage,noffset] ← PageAddress[n];
realnbuff ← GetPage[npage,nbuff];
vptr ← BufferTable[realnbuff].buffer + noffset + SIZE[NodeNumber];
IF (v ← vptr↑) = ZeroValue THEN v ← NIL;
Unlock[nbuff];
RETURN[v];
END;


--Private procedures--

BufferTable: ARRAY [0..4) OF BufferDesc;
BufferDesc: TYPE = RECORD [
page: INTEGER,
dirty: BOOLEAN,
lock: INTEGER,
buffer: POINTER
];

next4: ARRAY [0..4) OF CARDINAL ← [1, 2, 3, 0];

FileName: STRING ← [40];
uFH: crD.UFileHandle ← NIL;
bufferArea: POINTER;

OpenMergeFile: PROCEDURE[fileName: STRING] =
BEGIN
i: CARDINAL;
erc: ovD.ErrorCode;
buffer: POINTER;
FileName.length ← 0;
AppendString[FileName,fileName];
[erc,uFH] ← crD.OpenFile[[["Extractor"],[""]],[fileName],update];
IF erc#ovD.ok THEN MergeError["Problem opening file"];
IF crD.UFileTruncate[0,0,uFH]#ovD.ok THEN MergeError["Problem opening old file"];
bufferArea ← AllocateResidentPages[4];
buffer ← bufferArea;
FOR i IN [0..4) DO
BufferTable[i] ← [
page: -1,
dirty: FALSE,
lock: 0,
buffer: buffer];
buffer ← buffer + 256;
ENDLOOP;
END;

CloseMergeFile: PROCEDURE =
BEGIN
FreePages[bufferArea];
IF crD.UFileTruncate[0,0,uFH]#ovD.ok THEN MergeError["Problem truncating file"];
IF crD.CloseFile[uFH]#ovD.ok THEN MergeError["Problem closing file"];
uFH ← NIL;
--DestroyFile[NewFile[FileName,Read,OldFileOnly]];
END;

IntLookup: PROCEDURE[n: NodeNumber, nbuff: CARDINAL]
RETURNS[r: NodeNumber, rbuff: CARDINAL] =
--Return smallest number to which n has been merged, transitively closed
BEGIN
t: NodeNumber ← 0;
flag: BOOLEAN ← FALSE;
--find root, r, of n
[t,nbuff] ← GetValue[n,nbuff];
r ← n;
rbuff ← nbuff;
UNTIL flag OR t = r DO
r ← t;
[t,rbuff,flag] ← GetValue[r,rbuff]; --rbuff is only a hint on rhs
ENDLOOP;
IF flag THEN CallDebugger["Lookup called after LookSmall"];
IF n # r THEN [] ← SetValue[n,nbuff,r];
END;

IntLookup2: PROCEDURE[n: NodeNumber, nbuff: CARDINAL]
RETURNS[r: NodeNumber, rbuff: CARDINAL] =
--Return smallest number it can assign to n
BEGIN
t: NodeNumber;
flag: BOOLEAN ← FALSE;
--find root, r, of n
[t,nbuff,flag] ← GetValue[n,nbuff];
r ← n;
rbuff ← nbuff;
UNTIL flag OR t = r DO
r ← t;
[t,rbuff,flag] ← GetValue[r,rbuff]; --rbuff is only a hint on rhs
ENDLOOP;
IF n # r THEN [] ← SetValue[n,nbuff,r];-- otherwise you’ld destroy small value
IF flag THEN {
r ← LOOPHOLE[LOOPHOLE[t,LONG CARDINAL] - 2B10]
}
ELSE {
SmallValue ← SmallValue + 1;
[] ← SetValue[r,nbuff,LOOPHOLE[SmallValue+2B10]];
r ← SmallValue;
};
END;

SetValue: PROCEDURE[n: NodeNumber, nbuff: CARDINAL, v: NodeNumber]
RETURNS[realnbuff: CARDINAL] =
BEGIN
vptr: POINTER TO NodeNumber;
npage,noffset: CARDINAL;
IF n=v THEN RETURN; --not uncommon
[npage,noffset] ← PageAddress[n];
realnbuff ← GetPage[npage,nbuff];
vptr ← BufferTable[realnbuff].buffer + noffset;
IF vptr↑#v THEN --avoid setting .dirty if possible
BEGIN
vptr↑ ← v;
BufferTable[realnbuff].dirty ← TRUE;
END;
END;

GetValue: PROCEDURE[n: NodeNumber, nbuff: CARDINAL]
RETURNS[v: NodeNumber, realnbuff: CARDINAL, done:BOOLEAN] =
BEGIN
vptr: POINTER TO NodeNumber;
npage,noffset: CARDINAL;
[npage,noffset] ← PageAddress[n];
realnbuff ← GetPage[npage,nbuff];
vptr ← BufferTable[realnbuff].buffer + noffset;
IF (v ← vptr↑) = ZeroValue THEN v ← n;
done ← (LOOPHOLE[v,LONG CARDINAL] >= 2B10);
END;

Lock: PROCEDURE[n: NodeNumber, nbuff: CARDINAL] RETURNS[realnbuff: CARDINAL] =
BEGIN
npage,noffset: CARDINAL;
[npage,noffset] ← PageAddress[n];
realnbuff ← GetPage[npage,nbuff];
BufferTable[realnbuff].lock ← BufferTable[realnbuff].lock + 1;
END;

Unlock: PROCEDURE[buff: CARDINAL] =
BEGIN
BufferTable[buff].lock ← BufferTable[buff].lock - 1;
END;

UnlockAll: PROCEDURE =
BEGIN
i: CARDINAL;
FOR i IN [0..4) DO
BufferTable[i].lock ← 0;
ENDLOOP;
END;

LessThan: PROCEDURE[n1,n2: NodeNumber] RETURNS[BOOLEAN] =
BEGIN
c1: LONG CARDINAL ← LOOPHOLE[n1];
c2: LONG CARDINAL ← LOOPHOLE[n2];
RETURN[c1<c2];
END;

GetPage: PROCEDURE [page: CARDINAL, buff: CARDINAL]
RETURNS [realbuff: CARDINAL] =
--Get page from disk into realbuff
--buff is used as hint for present buffer holding page
BEGIN
freebuff: INTEGER ← -1;
ipage: INTEGER ← page;
realbuff ← buff;
THROUGH [0..4) DO
IF BufferTable[realbuff].page = ipage THEN RETURN;
IF BufferTable[realbuff].lock=0 AND
(freebuff=-1 OR ~BufferTable[realbuff].dirty) THEN freebuff ← realbuff;
realbuff ← next4[realbuff];
ENDLOOP;
IF freebuff=-1 THEN MergeError["No free paging buffer"];
realbuff ← freebuff;
IF BufferTable[realbuff].dirty THEN
WritePage[BufferTable[realbuff].buffer,BufferTable[realbuff].page];
ReadPage[BufferTable[realbuff].buffer,page];
BufferTable[realbuff].page ← page;
BufferTable[realbuff].dirty ← FALSE;
BufferTable[realbuff].lock ← 0;
END;

PageAddress: PROCEDURE [addr: LONG POINTER]
RETURNS [pageNum,addrInPage: CARDINAL] =
-- Returns 16 bit page # and address in page from 23 bit, 2-word index -
--specifically for 256 word pages
BEGIN
RETURN[BITSHIFT[LowHalf[addr],-6]+BITSHIFT[HighHalf[addr],10],
BITSHIFT[BITAND[LowHalf[addr], 077B],2]];
END;

ReadPage: PROCEDURE [memaddr: POINTER, page: CARDINAL] =
--Read a page to memory address memaddr
BEGIN
erc: ovD.ErrorCode;
bytesRead: CARDINAL;
[erc,bytesRead] ← crD.ReadPages[memaddr, 512, page, uFH];
IF erc#ovD.ok THEN MergeError["Read problem"];
IF bytesRead=0 THEN Zero[memaddr,256];
END;

WritePage: PROCEDURE [memaddr: POINTER, page: CARDINAL] =
--Write a page from memory address memaddr
BEGIN
IF crD.WritePages[memaddr, 512, page, uFH]#ovD.ok THEN
MergeError["Write problem"];
END;

HighHalf: PROCEDURE [LONG POINTER] RETURNS [INTEGER] =
MACHINE CODE BEGIN zEXCH; zPOP END;

LowHalf: PROCEDURE [LONG POINTER] RETURNS [INTEGER] =
MACHINE CODE BEGIN zPOP END;

GenValue: NodeNumber;
SmallValue: NodeNumber;
ZeroValue: NodeNumber = LOOPHOLE[LONG[0],NodeNumber];

MergeError: PUBLIC ERROR[reason: STRING] = CODE;

END.