language-Modula2-0.1: examples/Modula-2_Libraries/PMOS/sources/tests/sort2.mod
MODULE Sort2;
(********************************************************)
(* *)
(* File sort program *)
(* *)
(* This is a test of the PMOS file system, so *)
(* we're not particularly concerned about the *)
(* efficiency of the sorting algorithm. *)
(* However, it's better than Sort1. *)
(* *)
(* Programmer: P. Moylan *)
(* Last edited: 17 March 1995 *)
(* Status: Working, but a bit slow *)
(* Runs a lot faster when module Files replaced *)
(* by FileSys. This is certainly due to *)
(* insufficient cacheing; most probably the main *)
(* problem is the conservative FAT updating in *)
(* module Directories. *)
(* *)
(********************************************************)
FROM Files IMPORT
(* type *) File,
(* proc *) OpenFile, CloseFile, ReadRecord, WriteRecord, EOF,
FileSize, SetPosition;
IMPORT (*HardDisk,*) Floppy;
FROM Windows IMPORT
(* type *) Window, Colour, FrameType, DividerType,
(* proc *) OpenWindow, CloseWindow, Write, WriteString, WriteLn,
EditString, EditAborted, PressAnyKey;
FROM NumericIO IMPORT
(* proc *) ReadBufferedCardinal;
FROM Storage1 IMPORT
(* proc *) ALLOCATE, DEALLOCATE;
FROM IOErrorCodes IMPORT
(* type *) ErrorCode,
(* proc *) TranslateErrorCode;
(************************************************************************)
CONST testing = TRUE;
TYPE BufferPointer = POINTER TO ARRAY [0..0] OF CHAR;
VAR debug: Window;
(************************************************************************)
PROCEDURE less (first, second: BufferPointer; recordsize: CARDINAL)
: BOOLEAN;
(* Tests for first^ < second^. *)
VAR j: CARDINAL;
BEGIN
j := 0;
LOOP
(*# save, check(index=>off) *)
IF first^[j] > second^[j] THEN RETURN FALSE END(*IF*);
IF first^[j] < second^[j] THEN RETURN TRUE END(*IF*);
(*# restore *)
INC (j);
IF j >= recordsize THEN RETURN FALSE END(*IF*);
END (*LOOP*);
END less;
(************************************************************************)
PROCEDURE FindInsertionPoint (f: File; dataptr: BufferPointer;
recsize: CARDINAL; VAR (*OUT*) place: LONGCARD): ErrorCode;
(* Returns (assuming result is OK) with place equal to the point in *)
(* file f where dataptr^ should be inserted. *)
VAR low, mid, high, recordsize: LONGCARD; count: CARDINAL;
bufptr: BufferPointer;
status: ErrorCode;
BEGIN
ALLOCATE (bufptr, recsize);
status := OK;
recordsize := LONGCARD(recsize);
low := 0; high := FileSize(f) DIV recordsize;
LOOP
IF high = low THEN EXIT (*LOOP*) END(*IF*);
mid := (low+high) DIV 2;
status := SetPosition (f, recordsize*mid);
IF status = OK THEN
status := ReadRecord (f, bufptr, recsize, count);
END (*IF*);
IF status <> OK THEN EXIT(*LOOP*) END (*IF*);
IF less (bufptr, dataptr, recsize) THEN
low := mid + 1;
ELSE
high := mid;
END (*IF*);
END (*LOOP*);
place := recordsize*low;
DEALLOCATE (bufptr, recsize);
RETURN status;
END FindInsertionPoint;
(************************************************************************)
PROCEDURE ShiftData (f: File; place: LONGCARD; amount: CARDINAL): ErrorCode;
(* Creates a gap in file f, by shifting the contents from position *)
(* place onwards by amount bytes. It is assumed (because of the *)
(* logic of the rest of the program) that the size of f is already *)
(* an integral multiple of amount. *)
CONST buffersize = 4096;
VAR bufptr: BufferPointer; oldpos, remaining: LONGCARD;
status: ErrorCode; dummy: CARDINAL;
BEGIN
ALLOCATE (bufptr, buffersize);
oldpos := FileSize (f);
remaining := oldpos - place;
status := OK;
LOOP
IF remaining < buffersize THEN EXIT(*LOOP*) END(*IF*);
DEC (oldpos, buffersize);
status := SetPosition (f, oldpos);
IF status = OK THEN
status := ReadRecord (f, bufptr, buffersize, dummy);
END (*IF*);
IF status <> OK THEN EXIT(*LOOP*) END (*IF*);
status := SetPosition (f, oldpos+LONGCARD(amount));
IF status = OK THEN
status := WriteRecord (f, bufptr, buffersize);
END (*IF*);
IF status <> OK THEN EXIT(*LOOP*) END (*IF*);
DEC (remaining, buffersize);
END (*LOOP*);
(* We still have to move a chunk at the beginning. *)
IF (status = OK) AND (remaining > 0) THEN
status := SetPosition (f, place);
IF status = OK THEN
status := ReadRecord (f, bufptr, CARDINAL(remaining), dummy);
END (*IF*);
IF status = OK THEN
status := SetPosition (f, place+LONGCARD(amount));
END (*IF*);
IF status = OK THEN
status := WriteRecord (f, bufptr, CARDINAL(remaining));
END (*IF*);
END (*IF*);
DEALLOCATE (bufptr, buffersize);
RETURN status;
END ShiftData;
(************************************************************************)
PROCEDURE InsertRecord (f: File; dataptr: BufferPointer;
recordsize: CARDINAL): ErrorCode;
(* Inserts a new record into file f. *)
VAR place: LONGCARD;
status: ErrorCode;
BEGIN
status := FindInsertionPoint (f, dataptr, recordsize, place);
IF status = OK THEN
status := ShiftData (f, place, recordsize);
END (*IF*);
IF status = OK THEN
status := SetPosition (f, place);
END (*IF*);
IF status = OK THEN
status := WriteRecord (f, dataptr, recordsize);
END (*IF*);
RETURN status;
END InsertRecord;
(************************************************************************)
PROCEDURE InsertionSort;
(* Reads a file sequentially, creates a sorted version in a new *)
(* file. For now, we are using an insertion sort method. *)
VAR infile, outfile: File; log, w: Window;
j: CARDINAL; count: CARDINAL;
name, errbuf: ARRAY [0..40] OF CHAR;
status: ErrorCode;
BufSize: CARDINAL;
Bufptr: BufferPointer;
BEGIN
BufSize := 20;
OpenWindow (w, white, black, 0, 16, 0, 79,
noframe, nodivider);
OpenWindow (log, white, black, 17, 24, 0, 79,
simpleframe, nodivider);
WriteString (log, "I/O Test Program: should produce a sorted file");
WriteLn (log);
WriteString (log, "Source file name (full path name): ");
name := "C:\PMOS\TESTS\UNSORTED.DAT";
EditString (log, name, SIZE(name));
IF EditAborted() THEN status := OperationAborted
ELSE status := OpenFile (infile, name, FALSE);
END (*IF*);
IF status = OK THEN
WriteLn (log);
WriteString (log, "Copy to file (full path name): ");
name := "A:TEST1.TMP";
EditString (log, name, SIZE(name));
IF EditAborted() THEN status := OperationAborted
ELSE status := OpenFile (outfile, name, TRUE);
END (*IF*);
IF status = OK THEN
WriteLn (log); WriteString (log, "Record size: ");
BufSize := ReadBufferedCardinal (log, 4);
ALLOCATE (Bufptr, BufSize);
WHILE NOT EOF(infile) DO
IF testing THEN
WriteLn (debug);
WriteString (debug, "About to read a record");
END (*IF*);
status := ReadRecord (infile, Bufptr, BufSize, count);
IF testing THEN
WriteLn (debug);
WriteString (debug, "Read one record");
END (*IF*);
IF status <> OK THEN
WriteLn (log); WriteString (log, "Read Error!");
ELSIF count > 0 THEN
FOR j := 0 TO count-1 DO
(*# save, check(index=>off) *)
Write (w, Bufptr^[j]);
(*# restore *)
END (*FOR*);
status := InsertRecord (outfile, Bufptr, BufSize);
IF status <> OK THEN
WriteLn (log); WriteString (log, "Write Error!");
END (*IF*);
END (*IF*);
END (*WHILE*);
IF testing THEN
WriteLn (debug);
WriteString (debug, "Have written last record");
END (*IF*);
DEALLOCATE (Bufptr, BufSize);
ELSE
WriteLn (log); WriteString (log, "Could not open output file");
WriteLn (log); WriteString (log, "Error code ");
TranslateErrorCode (status, errbuf);
WriteString (log, errbuf);
END (*IF successfully opened output file*);
IF testing THEN
WriteLn (debug); WriteString (debug, "Calling CloseFile");
END (*IF*);
CloseFile (outfile);
ELSE
WriteLn (log); WriteString (log, "Could not open input file");
WriteLn (log); WriteString (log, "Error code ");
TranslateErrorCode (status, errbuf);
WriteString (log, errbuf);
END (*IF successfully opened input file*);
CloseFile (infile);
WriteLn (log); WriteString (log, "End of Sort");
PressAnyKey (log);
CloseWindow (w); CloseWindow (log);
END InsertionSort;
(************************************************************************)
(* MAIN PROGRAM *)
(************************************************************************)
BEGIN
IF testing THEN
OpenWindow (debug, white, black, 12, 16, 0, 79,
simpleframe, nodivider);
END (*IF*);
InsertionSort;
END Sort2.