FEAT: Block SORT comparator

resolves: Oldes/Rebol-issues#2684

Author: Oldes

src/boot/actions.reb

@@ -378,7 +378,7 @@ sort: action [
 	/skip {Treat the series as records of fixed size}
 	size [integer!] {Size of each record}
 	/compare  {Comparator offset or function}
-	comparator [integer! any-function!]
+	comparator [integer! block! any-function!]
 	/part {Limits the sorting to a given length or position}
 	range [number! series!]
 	/all {Compare all fields}

src/core/t-block.c

@@ -459,6 +459,28 @@ static void No_Nones_Or_Logic(REBVAL *arg) {
 	return result;
 }
 
+/***********************************************************************
+**
+*/	static int Compare_Val_Multi(const void* v1, const void* v2)
+/*
+**	Used to compare multiple values in the record (sort/compare with block).
+**
+***********************************************************************/
+{
+	REBVAL* val = DS_GET(DSP - 1);
+	REBU64 flags = VAL_UNT64(DS_TOP);
+	REBLEN offset = 0;
+	REBINT result = 0;
+	ASSERT1(IS_BLOCK(val), RP_BAD_EVALTYPE);
+	REBVAL* ofs = VAL_BLK_DATA(val);
+	while (result == 0 && IS_INTEGER(ofs)) {
+		offset = AS_REBLEN(VAL_INT64(ofs++) - 1);
+		result = Cmp_Value((REBVAL*)v1 + offset, (REBVAL*)v2 + offset, GET_FLAG(flags, SORT_FLAG_CASE));
+	}
+	if (GET_FLAG(flags, SORT_FLAG_REVERSE)) result = -result;
+	return result;
+}
+
 /***********************************************************************
 **
 */	static int Compare_All_Val(const void *v1, const void *v2)
@@ -579,10 +601,28 @@ static void No_Nones_Or_Logic(REBVAL *arg) {
 	// Use fast quicksort library function:
 	if (skip > 1) len /= skip, size *= skip;
 
-	if (ANY_FUNC(compv))
-		reb_qsort((void *)VAL_BLK_DATA(block), len, size, Compare_Call);
-	else
-		reb_qsort((void *)VAL_BLK_DATA(block), len, size, (all && skip > 1) ? Compare_All_Val : Compare_Val);
+	int (*cmp)(const void*, const void*);
+
+	if (ANY_FUNC(compv)) {
+		cmp = Compare_Call;
+	}
+	else if (all && skip > 1) {
+		cmp = Compare_All_Val;
+	}
+	else if (IS_BLOCK(compv)) {
+		// Validate first...
+		REBVAL* tmp = VAL_BLK_DATA(compv);
+		while (!IS_END(tmp)) {
+			if (!IS_INTEGER(tmp) || VAL_INT64(tmp) < 1)
+				Trap1(RE_INVALID_ARG, tmp);
+			tmp++;
+		}
+		cmp = Compare_Val_Multi;
+	}
+	else {
+		cmp = Compare_Val;
+	}
+	reb_qsort((void*)VAL_BLK_DATA(block), len, size, cmp);
 
 	// Stored comparator and flags are not needed anymore
 	DS_DROP;

src/core/t-string.c

@@ -638,6 +638,10 @@ static const cmp_func sfunc_table[2][2][2][2] = {
 		DS_PUSH_INTEGER(flags);
 		sfunc = Compare_Comp;
 	}
+	else if (IS_BLOCK(compv)) {
+		// Not implemented for string series.
+		Trap0(RE_FEATURE_NA);
+	}
 	else {
 		// Store the skip (used to implement /all)
 		DS_PUSH_INTEGER(all ? skip : 1);

src/tests/units/series-test.r3

@@ -1742,6 +1742,21 @@ Rebol [
 	;@@ https://github.com/Oldes/Rebol-issues/issues/721
 	--assert [4 3 2 1] = sort/compare [1 2 3 4] :greater?
 
+	;@@ https://github.com/Oldes/Rebol-issues/issues/2684
+	--assert (sort/skip ["A2" "B3" "C1" "A1" "B2" "C3" "A3" "B1" "C2"] 3)
+			== ["A1" "B2" "C3" "A2" "B3" "C1" "A3" "B1" "C2"]
+	--assert (sort/skip/compare ["A2" "B3" "C1" "A1" "B2" "C3" "A3" "B1" "C2" ] 3 [ 3 2 1 ])
+			== ["A2" "B3" "C1" "A3" "B1" "C2" "A1" "B2" "C3"]
+	--assert (sort/skip/compare [ "A2" "B3" "C1" "A1" "B2" "C3" "A3" "B1" "C2" ] 3 [ 2 3 1 ])
+			== ["A3" "B1" "C2" "A1" "B2" "C3" "A2" "B3" "C1"]
+	--assert (sort/skip/compare [ "A2" "B3" "C1" "A1" "B2" "C3" "A3" "B1" "C2" ] 3 [ 2 1 3 ])
+			== ["A3" "B1" "C2" "A1" "B2" "C3" "A2" "B3" "C1"]
+	--assert (sort/skip/compare [ "A2" "B3" "C1" "A1" "B2" "C3" "A3" "B1" "C2" ] 3 [ 1 2 3 ])
+			== ["A1" "B2" "C3" "A2" "B3" "C1" "A3" "B1" "C2"]
+	--assert all [error? e: try [sort/skip/compare [3 B 1 B] 2 [2 -1]] e/id = 'invalid-arg]
+	--assert all [error? e: try [sort/skip/compare [3 B 1 B] 2 [2 0]] e/id = 'invalid-arg]
+	--assert all [error? e: try [sort/skip/compare [3 B 1 B] 2 [2 x]] e/id = 'invalid-arg]
+
 --test-- "SORT/compare string!"
 	;@@ https://github.com/Oldes/Rebol-issues/issues/1100
 	comp: func [a b] [a > b]