-- Edited April 22, 1976  10:30 PM
DIRECTORY
  segdefs: INCLUDE "<mps>segdefs",
  jsysdefs: INCLUDE "<mps>jsysdefs";
sortmerge: PROGRAM =
  BEGIN
  
  tempfiledesc: TYPE = RECORD [
    tfjfn, tfruns, tfdummy: INTEGER];

  t1, t2, t3, tt: tempfiledesc;

  shandle: TYPE = RECORD [
    array: DESCRIPTOR FOR ARRAY OF WORD];

  mtrec: shandle _ DESCRIPTOR [777777B,0];

  index: DESCRIPTOR FOR ARRAY OF shandle;

  activenodes: INTEGER; -- for debugging
  sortzoneseg, sortzone, sortannex: INTEGER;
  sortzonesize: INTEGER _ 100000B;
  mergezonesize: INTEGER _ 2000B;
  indexsize: INTEGER _ 10000B;
  lastindex: INTEGER;
  NoRoomInZone: SIGNAL;
  ZoneAlmostFull: BOOLEAN;

  readrecord, read2record, comparerecord, combinerecord: PROCEDURE;

  gettempfile: PROCEDURE [fname: STRING] RETURNS [jfn: INTEGER] =
    BEGIN
    jfn _ OpenFile[fname, 001000B6, ReadAccess+WriteAccess];
      -- options would be 11000 if deleting temp file worked.
    END;

  delerr: SIGNAL CODE;
  deletefile: PROCEDURE [jfn: INTEGER] =
    BEGIN
    err: INTEGER;
    IF JSYS [delf, jfn:err:] # 2
      THEN SIGNAL delerr [err];
    CloseFile[jfn, FALSE];
    END;

  outtotemp: PROCEDURE [jfn: INTEGER, rec: shandle] =
    BEGIN
    JSYS [bout, jfn, LENGTH[rec$array]];
    IF LENGTH[rec$array] > 0
      THEN JSYS [sout, jfn, 444400B6+BASE[rec$array], -LENGTH[rec$array]];
    END;

  infromtemp: PROCEDURE [jfn: INTEGER] RETURNS [rec: shandle] =
    BEGIN
    size: INTEGER;
    JSYS [bin, jfn: ,size];
    IF size = 0
      THEN RETURN [mtrec];
    rec _ DESCRIPTOR [ MakeNode[sortzone, size], size];
    BUMP activenodes;
    JSYS [sin, jfn, 444400B6+BASE[rec$array], -size];
    END;

  infrom1: PROCEDURE RETURNS [shandle] =
    BEGIN
    RETURN [infromtemp[t1$tfjfn]];
    END;

  infrom2: PROCEDURE RETURNS [shandle] =
    BEGIN
    RETURN [infromtemp[t2$tfjfn]];
    END;

  outto3: PROCEDURE [rec: shandle] =
    BEGIN
    outtotemp[t3$tfjfn, rec];
    END;

  rewindtrace: BOOLEAN _ FALSE;
  rewinding, rewinderror: SIGNAL CODE;
  rewind: PROCEDURE [jfn: INTEGER] =
    BEGIN
    err: INTEGER;
    IF rewindtrace
      THEN SIGNAL rewinding [jfn];
    IF JSYS [ sfptr, jfn, 0: err:] # 2
      THEN SIGNAL rewinderror [err];
    END;

  runjfn: PROCEDURE RETURNS [jfn: INTEGER] =
    BEGIN
    IF t1$tfdummy = 0 AND t2$tfdummy = 0
      THEN
	BEGIN
	tt _ t1;
	t1$tfdummy _ t2$tfruns - t1$tfruns;
	t1$tfruns _ t2$tfruns;
	t2$tfdummy _ tt$tfruns;
	t2$tfruns _ t2$tfruns + tt$tfruns;
	END;
    IF t1$tfdummy < t2$tfdummy
      THEN
	BEGIN
	jfn _ t2$tfjfn;
	t2$tfdummy _ t2$tfdummy-1;
	END
      ELSE
	BEGIN
	jfn _ t1$tfjfn;
	t1$tfdummy _ t1$tfdummy-1;
	END;
    END;

  siftup: PROCEDURE [first, last: INTEGER] =
    BEGIN
    i, j, smallson, last2: INTEGER;
    key, bs, bs1: shandle;
    i _ first;
    last2 _ last/2;
    (siftloop) WHILE i <= last2 DO
      BEGIN
      key _ index[i];
      smallson _ i*2;
      bs _ index[smallson];
      IF smallson < last AND smaller[(bs1 _ index[smallson+1]), bs]
	THEN 
	  BEGIN
	  smallson _ smallson+1;
	  bs _ bs1;
	  END;
      IF smaller[bs,key]
        THEN
	  BEGIN
	  index[i] _ bs;
	  index[smallson] _ key;
	  i _ smallson;
	  END
	ELSE EXIT siftloop;
      END;
    END;

  smaller: PROCEDURE [a,b: shandle] RETURNS [BOOLEAN] =
    BEGIN
    RETURN [ comparerecs[a,b] < 0];
    END;

  comparerecs: PROCEDURE [a,b: shandle] RETURNS [INTEGER] =
    BEGIN
    IF a = mtrec
      THEN RETURN [ IF b = mtrec THEN 0 ELSE 1];
    IF b = mtrec
      THEN RETURN[-1];
    RETURN[comparerecord[a,b]];
    END;

  recordin: PROCEDURE RETURNS [rec: shandle] =
    BEGIN
    irec: shandle;
    size: INTEGER;
    irec _ readrecord[];
    size _ LENGTH[irec$array];
    IF size = 0
      THEN RETURN [mtrec];
    rec _ DESCRIPTOR [ MakeNode[sortzone, size], size];
    BUMP activenodes;
    Copy[ BASE[irec$array], BASE[rec$array], size];
    END;

  record2in: PROCEDURE RETURNS [rec: shandle] =
    BEGIN
    irec: shandle;
    size: INTEGER;
    irec _ read2record[];
    size _ LENGTH[irec$array];
    IF size = 0
      THEN RETURN [mtrec];
    rec _ DESCRIPTOR [ MakeNode[sortzone, size], size];
    BUMP activenodes;
    Copy[ BASE[irec$array], BASE[rec$array], size];
    END;

  combineequalrecs: PROCEDURE [a,b: shandle] RETURNS [c: shandle] =
    BEGIN
    size: INTEGER;
    ic: shandle;
    IF a = mtrec
      THEN RETURN [mtrec];
    ic _ combinerecord[a,b];
    size _ LENGTH[ic$array];
    c _ DESCRIPTOR [ MakeNode[sortzone, size], size];
    BUMP activenodes;
    Copy[ BASE[ic$array], BASE[c$array], size];
    FreeNode[sortzone, BASE[ a$array]]; FreeNode[sortzone, BASE[b$array]];
    activenodes _ activenodes-2;
    END;

  mergesort: PROCEDURE [rrproc, writerecord, cprproc, cbrproc: PROCEDURE, allowequal: BOOLEAN] =
    BEGIN
    i, lastout, lastinrun, rjfn: INTEGER;
    nextrec, next1rec, next2rec, prevrec, old1: shandle;
    firstinmergedrun: BOOLEAN;

    ENABLE NoRoomInZone:
      BEGIN
      IF ZoneAlmostFull
	THEN ERROR;
      ZoneAlmostFull _ TRUE;
      AddToZone[ sortzone, sortannex, 1000B];
      RESUME;
      END;

    readrecord _ rrproc;
    comparerecord _ cprproc;
    combinerecord _ cbrproc;

    sortzoneseg _ NewData[sortzonesize,0];
    sortzone _ MakeZone[ RealAddress[sortzoneseg], sortzonesize];
    index _ DESCRIPTOR [ mplAllocate[indexsize]-1, indexsize+1];
    sortannex _ mplAllocate[ 1000B];

    ZoneAlmostFull _ FALSE; activenodes _ 0;
    lastindex _ 0;

    UNTIL (nextrec _ recordin[]) = mtrec OR ZoneAlmostFull OR lastindex = indexsize DO
      BEGIN
      lastindex _ lastindex + 1;
      index[lastindex] _ nextrec;
      END;

    FOR i DOWN THRU [2..lastindex/2] DO
      siftup[i,lastindex];

    IF nextrec = mtrec
      THEN
	BEGIN
	firstinmergedrun _ TRUE;
	FOR i DOWN THRU [1..lastindex] DO
	  BEGIN
	  siftup[1, i];
	  IF firstinmergedrun
	    THEN firstinmergedrun _ FALSE
	    ELSE IF ~ allowequal AND comparerecs[ prevrec, index[1]] = 0
	      THEN index[1] _ combineequalrecs[ prevrec, index[1]]
	      ELSE 
		BEGIN
		writerecord[ prevrec];
		FreeNode[ sortzone, BASE[prevrec$array]];
		activenodes _ activenodes -1;
		END;
	  prevrec _ index[1];
	  index[1] _ index[i];
	  END;
	writerecord[prevrec];
	ReleaseSeg[sortzoneseg];
	mplFree[BASE[index]+1];
	mplFree[sortannex];
	RETURN;
	END;

    t1$tfjfn _ gettempfile["$sort$.temp1"];
    t2$tfjfn _ gettempfile["$sort$.temp2"];
    t1$tfruns _ t2$tfruns _ t1$tfdummy _ t2$tfdummy _ 1;

    (genruns) DO
      BEGIN
      lastinrun _ lastindex;
      rjfn _ runjfn[];

      WHILE lastinrun > 0 AND nextrec # mtrec DO
	BEGIN
	siftup[1, lastinrun];
	old1 _ index[1];
	outtotemp[rjfn, old1];
	IF smaller [old1, nextrec]
	  THEN index[1] _ nextrec
	  ELSE
	    BEGIN
	    index[1] _ index[lastinrun];
	    index[lastinrun] _ nextrec;
	    lastinrun _ lastinrun - 1;
	    END;
	FreeNode[sortzone, BASE[old1$array]];
	activenodes _ activenodes - 1;
	nextrec _ recordin[];
	END;

      FOR i DOWN THRU [1..lastinrun] DO
	BEGIN
	siftup[1, i];
	outtotemp[rjfn, index[1]];
	IF index[1] = mtrec
	  THEN EXIT genruns;
	FreeNode[sortzone, BASE[index[1]$array]];
	activenodes _ activenodes - 1;
	index[1] _ index[i];
	index[i] _ mtrec;
	END;

      outtotemp[rjfn, mtrec];

      IF nextrec = mtrec AND lastinrun = lastindex
	THEN EXIT genruns;

      FOR i DOWN THRU [2.. lastindex/2] DO
	siftup[i, lastindex];

      END; -- genruns

    rewind[t1$tfjfn];

    t3$tfjfn _ gettempfile["$sort$.temp3"];

    (mergephase) WHILE t1$tfruns > 1 OR t2$tfruns > 1 DO
      BEGIN

      rewind[t2$tfjfn]; rewind[t3$tfjfn];
      t3$tfruns _ t3$tfdummy _ 0;

      WHILE t1$tfruns > 0 DO
	BEGIN
	t1$tfruns _ t1$tfruns - 1;
	t2$tfruns _ t2$tfruns - 1;
	t3$tfruns _ t3$tfruns + 1;

	IF t1$tfdummy > 0
	  THEN
	    BEGIN
	    t1$tfdummy _ t1$tfdummy - 1;
	    t2$tfdummy _ t2$tfdummy - 1;
	    t3$tfdummy _ t3$tfdummy + 1;
	    END
	  ELSE IF t2$tfdummy > 0
	    THEN
	      BEGIN
	      t2$tfdummy _ t2$tfdummy - 1;
	      DO
		BEGIN
		next1rec _ infromtemp[t1$tfjfn];
		outtotemp[t3$tfjfn, next1rec];
		END
	      UNTIL next1rec = mtrec;
	      END
	    ELSE
	      BEGIN
	      xmerge[ PROCEDURE infrom1, PROCEDURE infrom2, PROCEDURE outto3, allowequal];
	      outtotemp[t3$tfjfn, mtrec];
	      END;
	END; 
      tt _ t1;
      t1 _ t2;
      t2 _ t3;
      t3 _ tt;

      END; -- mergephase

    deletefile[ t3$tfjfn];
    IF t2$tfdummy > 0
      THEN outtotemp[t2$tfjfn, mtrec];
    rewind[t2$tfjfn];

    xmerge[ PROCEDURE infrom1, PROCEDURE infrom2, writerecord, allowequal];

    deletefile[t1$tfjfn]; deletefile[t2$tfjfn];
    ReleaseSeg[sortzoneseg];
    mplFree[BASE[index]+1];
    mplFree[sortannex];

    END;

  merge: PROCEDURE [rrproc, rr2proc, writerecord, cprproc, cbrproc: PROCEDURE, allowequal: BOOLEAN] =
    BEGIN
    readrecord _ rrproc;
    read2record _ rr2proc;

    comparerecord _ cprproc;
    combinerecord _ cbrproc;

    sortzoneseg _ NewData[mergezonesize,0];
    sortzone _ MakeZone[ RealAddress[sortzoneseg], mergezonesize];

    ZoneAlmostFull _ FALSE; activenodes _ 0;
    xmerge[PROCEDURE recordin, PROCEDURE record2in, writerecord, allowequal];
    ReleaseSeg[sortzoneseg];
    END;

  xmerge: PROCEDURE [read1, read2, writerecord: PROCEDURE, allowequal: BOOLEAN] =
    BEGIN
    i: INTEGER;
    nextrec, next1rec, next2rec, prevrec: shandle;
    firstinmergedrun: BOOLEAN;

    next1rec _ read1[];
    next2rec _ read2[];
    firstinmergedrun _ TRUE;
    DO
      BEGIN
      CASE comparerecs[next1rec, next2rec] OF
	<0:
	  BEGIN
	  nextrec _ next1rec;
	  IF next1rec # mtrec
	    THEN next1rec _ read1[];
	  END;
	>0:
	  BEGIN
	  nextrec _ next2rec;
	  IF next2rec # mtrec
	    THEN next2rec _ read2[];
	  END;
	ENDCASE: IF allowequal
	  THEN 
	    BEGIN
	    nextrec _ next1rec;
	    IF next1rec # mtrec
	      THEN next1rec _ read1[];
	    END
	  ELSE IF next1rec # mtrec
	    THEN 
	      BEGIN
	      nextrec _ combineequalrecs[next1rec, next2rec];
	      next1rec _ read1[];
	      next2rec _ read2[];
	      END
	    ELSE nextrec _ mtrec;
       IF firstinmergedrun
	THEN
	  BEGIN
	  firstinmergedrun _ FALSE;
	  prevrec _ nextrec;
	  END
	ELSE IF ~ allowequal AND comparerecs[ nextrec, prevrec] = 0
	  THEN prevrec _ combineequalrecs[ nextrec, prevrec]
	  ELSE 
	    BEGIN
	    writerecord[prevrec];
	    IF prevrec # mtrec
	      THEN 
		BEGIN
		FreeNode[sortzone, BASE[prevrec$array]];
		activenodes _ activenodes - 1;
		END;
	    prevrec _ nextrec;
	    END;
      END
    UNTIL nextrec = mtrec;
    END;


  END...
p1