// S O R T // Copyright Xerox Corporation 1979 // A wonderful general-purpose BCPL sorting package // E. McCreight // last modified October 4, 1977 11:23 PM by McCreight // The Sort subroutine is invoked with three other subroutines // and two optional numbers as // arguments. GetItem is a routine which returns the length // of a new item (or 0 if no more items exist) which it has // placed in the buffer passed to it. // CompareItems returns a positive number if the first item // is greater, zero if they are equal, and a negative number if // the second item is greater. PutItem is a routine which will // write out (or whatever) items after they have been sorted. // ExpectedItemSize and MaxItemSize, if present, help // the system partition internal storage in reasonable ways. get "streams.d" external [ FixedLeft GetFixed FreeFixed CallSwat SysErr InitializeZone Allocate Free MoveBlock OpenFile Gets Puts Resets ReadBlock WriteBlock Closes DeleteFile DefaultArgs sysDisk Sort DeleteScratch ] manifest [ NFiles = 3 DefaultExpItemSize = 10 // Words DefaultMaxItemSize = 1000 AllocNodeOvhd = 1 infinity = #77777 ] structure HE: [ ItemLen word Record word ] structure FD: [ FileName word Stream word EndOfRun word DummyRuns word TotalRuns word ItemLen word Buffer word BHeadIndex word // First occupied word BTailIndex word // First free word Record word ] static [ SortZone SortDisk ReleaseZone Files Level ItemIsLeftOver LeftoverItem LeftoverItemLen MaxHeapSize RecordSize BufferSize InputFinished Heap HeapSize // end of Heap-sorted part of heap vector FirstFreeEnt // 1+end of unsorted part of heap vector MaxItemWords OccItemWords DeleteScratch ] let Sort(GetItem, PutItem, CompareItems, ExpectedItemSize, MaxItemSize, SZ, disk; numargs na) be [ DefaultArgs(lv na,-3,DefaultExpItemSize,DefaultMaxItemSize,0,sysDisk) SortDisk = disk Initialize(SZ, ExpectedItemSize, MaxItemSize) // Set up storage structures Heap = Allocate(SortZone, MaxHeapSize+1) FirstFreeEnt = 1 // First, fill up the heap as much as possible and // sort it. LeftoverItem = Allocate(SortZone, RecordSize) ItemIsLeftOver = false InputFinished = false BuildHeap(GetItem, CompareItems) if InputFinished then [ // One heap's worth was enough! Goodie! for i=1 to HeapSize do [ let Item = GetHeap(GetItem, CompareItems) PutItem(lv (Item>>HE.Record), Item>>HE.ItemLen) ] FreeAllocatedStuff() return ] let FileName = vec NFiles+1 FileName!1 = "SORT.SCRATCH1" FileName!2 = "SORT.SCRATCH2" FileName!3 = "SORT.SCRATCH3" for i=1 to NFiles do [ let File = Files!i File>>FD.FileName = FileName!i test i ls NFiles ifso [ File>>FD.Stream = OpenFile(FileName!i, ksTypeReadWrite, wordItem,0,0,0,0,0,SortDisk) File>>FD.TotalRuns = 1 File>>FD.DummyRuns = 1 ] ifnot [ File>>FD.TotalRuns = 0 File>>FD.DummyRuns = 0 ] ] BuildRuns(GetItem, CompareItems) // Put runs on input files 1...NFiles-1 // so that they have Fibonacci relationship Free(SortZone, LeftoverItem) LeftoverItem = 0 Free(SortZone, Heap) Heap = 0 if Level gr 1 then [ let LastFile = Files!NFiles LastFile>>FD.Stream = OpenFile(LastFile>>FD.FileName, ksTypeReadWrite, wordItem,0,0,0,0,0,SortDisk) ] let Oops = 0 Allocate(SortZone, #77777, lv Oops) // coalesce free space for i=1 to NFiles do [ let File = Files!i File>>FD.Buffer = Allocate(SortZone, BufferSize) File>>FD.BHeadIndex = 0 File>>FD.BTailIndex = 0 ] // Now carry out merge passes until the level has returned // to zero. DeleteScratch = false // scratch file may not exist until Level eq 0 do [ MergePass(CompareItems, PutItem) // also cycles the files afterward if Level>1 Level = Level-1 if Level eq 1 then [ // Output will go to the PutItem routine Closes((Files!NFiles)>>FD.Stream) DeleteScratch = true // it exists, and we'll delete it // unless our caller's PutItem // minion toggles DeleteScratch ] ] for i=1 to NFiles-1 do [ Closes((Files!i)>>FD.Stream) DeleteFile((Files!i)>>FD.FileName,0,0,0,0,SortDisk) ] if DeleteScratch then DeleteFile((Files!NFiles)>>FD.FileName,0,0,0,0,SortDisk) FreeAllocatedStuff() ] and Initialize(SZ, ExpectedItemSize, MaxItemSize) be [ test SZ eq 0 ifso [ let BlockSize = FixedLeft()-1000 if UGR(BlockSize, #77777) then BlockSize = #77777 SortZone = GetFixed(BlockSize) InitializeZone(SortZone, BlockSize, SysErr, 0) ReleaseZone = true ] ifnot [ SortZone = SZ ReleaseZone = false ] Files = Allocate(SortZone, NFiles+1) for i=1 to NFiles do [ let File = Allocate(SortZone, size FD/16) Files!i = File File>>FD.Buffer = 0 File>>FD.Record = 0 ] let BlockSize = 0 // find the biggest single block Allocate(SortZone, #77777, lv BlockSize) BufferSize = (BlockSize-200)/NFiles RecordSize = BufferSize if RecordSize gr MaxItemSize then RecordSize = MaxItemSize MaxHeapSize = (BlockSize-(RecordSize+200))/(ExpectedItemSize+3) MaxItemWords = BlockSize-MaxHeapSize-RecordSize-200 OccItemWords = 0 ] and FreeAllocatedStuff() be [ for i=1 to NFiles do [ let File = Files!i if File>>FD.Buffer ne 0 then Free(SortZone, File>>FD.Buffer) if File>>FD.Record ne 0 then Free(SortZone, File>>FD.Record) Free(SortZone, File) ] Free(SortZone, Files) if Heap ne 0 then Free(SortZone, Heap) if LeftoverItem ne 0 then Free(SortZone, LeftoverItem) if ReleaseZone then FreeFixed(SortZone) ] and BuildRuns(GetItem, CompareItems) be [ Level = 1 let j = 1 // Continue reading and sorting, alternating in Fibonacci sequence, // until the input is exhausted. [ let File = Files!j if Level gr 1 then Puts(File>>FD.Stream, -1) // End-of-run marker let Item = GetHeap(GetItem, CompareItems) while Item ne 0 do [ let ItemLen = Item>>HE.ItemLen Puts(File>>FD.Stream, ItemLen) WriteBlock(File>>FD.Stream, lv (Item>>HE.Record), ItemLen) Free(SortZone, Item) OccItemWords = OccItemWords- ItemLen- (offset HE.Record/16)- AllocNodeOvhd Item = GetHeap(GetItem, CompareItems) ] let DummyRuns = File>>FD.DummyRuns-1 File>>FD.DummyRuns = DummyRuns if InputFinished & (FirstFreeEnt eq 1) then break test DummyRuns ls (Files!(j+1)>>FD.DummyRuns) ifso j = j+1 ifnot [ j = 1 if DummyRuns eq 0 then [ Level = Level+1 let A = (Files!1)>>FD.TotalRuns for i=1 to NFiles-1 do [ let LFile = Files!i let NT = A+(Files!(i+1))>> FD.TotalRuns LFile>>FD.DummyRuns = NT- LFile>>FD.TotalRuns LFile>>FD.TotalRuns = NT ] ] ] BuildHeap(GetItem, CompareItems) ] repeat for i=1 to NFiles-1 do [ Puts((Files!i)>>FD.Stream, -1) // end-of-run Resets((Files!i)>>FD.Stream) ] ] and MergePass(CompareItems, PutItem) be [ let OFile = Files!NFiles let LastFile = Files!(NFiles-1) let RunsThisPass = LastFile>>FD.TotalRuns let DummiesThisPass = infinity for i=1 to NFiles-1 do if (Files!i)>>FD.DummyRuns ls DummiesThisPass then DummiesThisPass = (Files!i)>>FD.DummyRuns OFile>>FD.TotalRuns = RunsThisPass OFile>>FD.DummyRuns = DummiesThisPass for i=1 to NFiles-1 do [ (Files!i)>>FD.TotalRuns = (Files!i)>>FD.TotalRuns-RunsThisPass (Files!i)>>FD.DummyRuns = (Files!i)>>FD.DummyRuns-DummiesThisPass ] for RunNo=DummiesThisPass+1 to RunsThisPass do MergeRun(OFile, LastFile, CompareItems, PutItem, RunNo) if Level gr 1 then [ FlushBuffer(OFile) for i=NFiles-1 to NFiles do [ let File = Files!i Resets(File>>FD.Stream) File>>FD.BHeadIndex = 0 File>>FD.BTailIndex = 0 ] // Cycle the files. let T = Files!NFiles for i=NFiles-1 to 1 by -1 do Files!(i+1) = Files!i Files!1 = T ] ] and BuildHeap(GetItem, CompareItems) be [ HeapSize = 0 MaintainHeap(GetItem, CompareItems) HeapSize = FirstFreeEnt-1 let L = (HeapSize/2)+1 while L gr 1 do [ L = L-1 SiftDown(L, Heap!L, CompareItems) ] ] and MaintainHeap(GetItem, CompareItems) be [ // Fill the heap as full as possible if InputFinished then return while FirstFreeEnt le MaxHeapSize do [ // Try adding another heap element unless ItemIsLeftOver do [ LeftoverItemLen = GetItem(LeftoverItem, RecordSize) if LeftoverItemLen gr RecordSize then CallSwat("Record too long.") unless LeftoverItemLen gr 0 do [ InputFinished = true return ] ] if OccItemWords ge MaxItemWords then [ ItemIsLeftOver = true return ] let Oops = 0 let Item = Allocate(SortZone, LeftoverItemLen+ (offset HE.Record/16), lv Oops) if Oops ne 0 then [ MaxItemWords = OccItemWords-100 ItemIsLeftOver = true return ] OccItemWords = OccItemWords+ LeftoverItemLen+ (offset HE.Record/16)+ AllocNodeOvhd Item>>HE.ItemLen = LeftoverItemLen MoveBlock(lv (Item>>HE.Record) ,LeftoverItem, LeftoverItemLen) Heap!FirstFreeEnt = Heap!(HeapSize+1) FirstFreeEnt = FirstFreeEnt+1 Heap!(HeapSize+1) = Item ItemIsLeftOver = false if HeapSize gr 0 & CompareItems(lv (Item>>HE.Record), lv ((Heap!1)>>HE.Record)) ge 0 then [ HeapSize = HeapSize+1 SiftUp(CompareItems) ] ] ] and GetHeap(GetItem, CompareItems) = valof [ if HeapSize eq 0 then resultis 0 MaintainHeap(GetItem, CompareItems) let Item = Heap!1 SiftDown(1, Heap!HeapSize, CompareItems) Heap!HeapSize = Heap!(FirstFreeEnt-1) HeapSize = HeapSize-1 FirstFreeEnt = FirstFreeEnt-1 resultis Item ] and SiftUp(CompareItems) be [ let J = HeapSize let K = Heap!HeapSize let I = J rshift 1 while I gr 0 do [ if CompareItems(lv ((Heap!I)>>HE.Record), lv (K>>HE.Record)) le 0 then break Heap!J = Heap!I J = I I = J rshift 1 ] Heap!J = K ] and SiftDown(L, K, CompareItems) be [ let J = L let I = nil [ I = J J = J+J if J gr HeapSize then break if J ls HeapSize then if CompareItems(lv ((Heap!J)>>HE.Record), lv ((Heap!(J+1))>>HE.Record)) gr 0 then J = J+1 if CompareItems(lv (K>>HE.Record), lv ((Heap!J)>>HE.Record)) le 0 then break Heap!I = Heap!J ] repeat Heap!I = K ] and MergeRun(OFile, LastFile, CompareItems, PutItem, RunNo) be [ // Process a run. Fill up the applicable records. for i=1 to NFiles-1 do [ let File = Files!i test File>>FD.DummyRuns eq 0 ifnot [ File>>FD.DummyRuns = File>>FD.DummyRuns-1 File>>FD.EndOfRun = true ] ifso ReadRecord(File) ] while true do [ let SR = 0 // selected record (which file is it from) for i=1 to NFiles-1 do if (not ((Files!i)>>FD.EndOfRun)) & (SR eq 0 % (CompareItems((Files!i)>>FD.Record, (Files!SR)>>FD.Record) ls 0)) then SR = i if SR eq 0 then break let File = (Files!SR) let ItemLen = File>>FD.ItemLen test Level eq 1 ifnot WriteRecord(OFile, ItemLen, File>>FD.Record) ifso PutItem(File>>FD.Record, ItemLen, OFile>>FD.FileName) File>>FD.Record = 0 // for cleanup guy ReadRecord(File) ] if Level gr 1 then WriteRecord(OFile, -1) // End-of-run marker ] and ReadRecord(File) = valof [ if File>>FD.BHeadIndex eq File>>FD.BTailIndex then FillBuffer(File) let HeadIndex = File>>FD.BHeadIndex let ItemLen = (File>>FD.Buffer)!HeadIndex HeadIndex = HeadIndex+1 File>>FD.BHeadIndex = HeadIndex if ItemLen ls 0 then [ File>>FD.EndOfRun = true resultis false ] if HeadIndex+ItemLen gr File>>FD.BTailIndex then FillBuffer(File) HeadIndex = File>>FD.BHeadIndex File>>FD.Record = lv ((File>>FD.Buffer)!HeadIndex) File>>FD.BHeadIndex = HeadIndex+ItemLen File>>FD.ItemLen = ItemLen File>>FD.EndOfRun = false resultis true ] and FillBuffer(File) be [ let Buffer = File>>FD.Buffer let HeadIndex = File>>FD.BHeadIndex let WordsInBuffer = File>>FD.BTailIndex-HeadIndex if WordsInBuffer gr 0 then MoveBlock(Buffer, lv (Buffer!HeadIndex), WordsInBuffer) let NewWords = ReadBlock(File>>FD.Stream, lv (Buffer!WordsInBuffer), BufferSize-WordsInBuffer) File>>FD.BHeadIndex = 0 File>>FD.BTailIndex = WordsInBuffer+NewWords ] and WriteRecord(File, ItemLen, Item) be [ let Buffer = File>>FD.Buffer let TailIndex = File>>FD.BTailIndex if TailIndex+((ItemLen ls 0)? 1, ItemLen+1) gr BufferSize then [ FlushBuffer(File) TailIndex = File>>FD.BTailIndex ] Buffer!TailIndex = ItemLen TailIndex = TailIndex+1 if ItemLen ge 0 then [ MoveBlock(lv (Buffer!TailIndex), Item, ItemLen) TailIndex = TailIndex+ItemLen ] File>>FD.BTailIndex = TailIndex ] and FlushBuffer(File) be [ WriteBlock(File>>FD.Stream, File>>FD.Buffer, File>>FD.BTailIndex) File>>FD.BTailIndex = 0 ] and UGR(X, Y) = table [ #106432; // SGTU 0,1 #102461; // MKZERO 0,0,SKP #102000; // MKMINUSONE 0,0 #1401 // JMP 1,3 ] (X, Y)