Added the ArraySort module

lang/m2/libm2/.distr

@@ -24,3 +24,4 @@ Traps.def
 CSP.def
 Epilogue.def
 Streams.def
+ArraySort.def

lang/m2/libm2/ArraySort.def

@@ -0,0 +1,26 @@
+DEFINITION MODULE ArraySort;
+(* 
+  Module:	Array sorting module
+  Author:	Ceriel J.H. Jacobs
+  Date:		$Header$
+
+  Interface is like the qsort() interface in C, so that an array of values
+  can be sorted. This does not mean that it has to be an ARRAY, but it does
+  mean that the values must be consecutive in memory, and the order is the
+  "memory" order.
+  The user has to define a comparison procedure of type CompareProc.
+  This routine gets two pointers as parameters. These are pointers to the
+  opbjects that must be compared. The sorting takes place in ascending order,
+  so that f.i. if the result of the comparison is "less", the first argument
+  comes in front of the second.
+*)
+  FROM SYSTEM IMPORT ADDRESS;	(* no generics in Modula-2, sorry *)
+
+  TYPE	CompareResult = (less, equal, greater);
+  	CompareProc = PROCEDURE(ADDRESS, ADDRESS): CompareResult;
+
+  PROCEDURE Sort(base: ADDRESS;		(* address of array *)
+		 nel: CARDINAL;		(* number of elements in array *)
+		 size: CARDINAL;	(* size of each element *)
+		 compar: CompareProc);	(* the comparison procedure *)
+END ArraySort.

lang/m2/libm2/ArraySort.mod

@@ -0,0 +1,150 @@
+(*$R-*)
+IMPLEMENTATION MODULE ArraySort;
+(* 
+  Module:	Array sorting module.
+  Author:	Ceriel J.H. Jacobs
+  Version:	$Header$
+*)
+  FROM SYSTEM IMPORT ADDRESS, BYTE;	(* no generics in Modula-2, sorry *)
+
+  TYPE BytePtr = POINTER TO BYTE;
+
+  VAR compareproc: CompareProc;
+
+  PROCEDURE Sort(base: ADDRESS;		(* address of array *)
+		 nel: CARDINAL;		(* number of elements in array *)
+		 size: CARDINAL;	(* size of each element *)
+		 compar: CompareProc);	(* the comparison procedure *)
+  BEGIN
+	compareproc := compar;
+	qsort(base, base+(nel-1)*size, size);
+  END Sort;
+
+  PROCEDURE qsort(a1, a2: ADDRESS; size: CARDINAL);
+    VAR	left, right, lefteq, righteq: ADDRESS;
+	cmp: CompareResult;
+	mainloop: BOOLEAN;
+  BEGIN
+	WHILE a2 > a1 DO
+		left := a1;
+		right := a2;
+		lefteq := a1 + size * (((a2 - a1) + size) DIV (2 * size));
+		righteq := lefteq;
+		(*
+                   Pick an element in the middle of the array.
+                   We will collect the equals around it.
+                   "lefteq" and "righteq" indicate the left and right
+                   bounds of the equals respectively.
+                   Smaller elements end up left of it, larger elements end
+                   up right of it.
+		*)
+		LOOP
+			LOOP
+				IF left >= lefteq THEN EXIT END;
+			      	cmp := compareproc(left, lefteq);
+				IF cmp = greater THEN EXIT END;
+				IF cmp = less THEN
+					left := left + size;
+				ELSE
+					(* equal, so exchange with the element
+					   to the left of the "equal"-interval.
+					*)
+					lefteq := lefteq - size;
+					exchange(left, lefteq, size);
+				END;
+			END;
+			mainloop := FALSE;
+			LOOP
+				IF right <= righteq THEN EXIT END;
+				cmp := compareproc(right, righteq);
+				IF cmp = less THEN
+					IF left < lefteq THEN
+						(* larger one at the left,
+						   so exchange
+						*)
+						exchange(left,right,size);
+						left := left + size;
+						right := right - size;
+						mainloop := TRUE;
+						EXIT;
+					END;
+                                (*
+ 				   no more room at the left part, so we
+                                   move the "equal-interval" one place to the
+                                   right, and the smaller element to the
+                                   left of it.
+                                   This is best expressed as a three-way
+                                   exchange.
+                                *)
+					righteq := righteq + size;
+					threewayexchange(left, righteq, right,
+						size);
+					lefteq := lefteq + size;
+					left := lefteq;
+				ELSIF cmp = equal THEN
+					(* equal, zo exchange with the element
+					   to the right of the "equal"
+					   interval
+					*)
+					righteq := righteq + size;
+					exchange(right, righteq, size);
+				ELSE
+					(* leave it where it is *)
+					right := right - size;
+				END;
+			END;
+			IF (NOT mainloop) THEN
+				IF left >= lefteq THEN
+					(* sort "smaller" part *)
+					qsort(a1, lefteq - size, size);
+					(* and now the "larger" part, saving a
+					   procedure call, because of this big
+					   WHILE loop
+					*)
+					a1 := righteq + size;
+					EXIT;	(* from the LOOP *)
+				END;
+                        	(* larger element to the left, but no more room,
+                      	     	   so move the "equal-interval" one place to the
+                           	   left, and the larger element to the right
+                           	   of it.
+                         	*)
+				lefteq := lefteq - size;
+				threewayexchange(right, lefteq, left, size);
+				righteq := righteq - size;
+				right := righteq;
+			END;
+		END;
+	END;
+  END qsort;
+
+  PROCEDURE exchange(a,b: BytePtr; size : CARDINAL);
+    VAR c: BYTE;
+  BEGIN
+	WHILE size > 0 DO
+		DEC(size);
+		c := a^;
+		a^ := b^;
+		a := ADDRESS(a) + 1;
+		b^ := c;
+		b := ADDRESS(b) + 1;
+	END;
+  END exchange;
+
+  PROCEDURE threewayexchange(p,q,r: BytePtr; size: CARDINAL);
+    VAR c: BYTE;
+  BEGIN
+	WHILE size > 0 DO
+		DEC(size);
+		c := p^;
+		p^ := r^;
+		p := ADDRESS(p) + 1;
+		r^ := q^;
+		r := ADDRESS(r) + 1;
+		q^ := c;
+		q := ADDRESS(q) + 1;
+	END;
+  END threewayexchange;
+
+END ArraySort.
+

lang/m2/libm2/LIST

@@ -16,6 +16,7 @@ Conversion.mod
 Semaphores.mod
 random.mod
 Strings.mod
+ArraySort.mod
 catch.c
 Traps.mod
 Arguments.c

lang/m2/libm2/Makefile

@@ -6,7 +6,7 @@ SOURCES =	ASCII.def EM.def MathLib0.def Processes.def \
 		random.def Semaphores.def Unix.def RealConver.def \
 		Strings.def InOut.def Terminal.def TTY.def \
 		Mathlib.def PascalIO.def Traps.def CSP.def \
-		Epilogue.def Streams.def
+		Epilogue.def Streams.def ArraySort.def
 
 all: