FEAT: implement SORT/COMPARE on any-string! values

fixes: Oldes/Rebol-issues#1100

Author: Oldes

src/core/t-block.c

@@ -428,7 +428,6 @@ static struct {
 		if (VAL_DECIMAL(val) == 0) return 0;
 		return -1;
 	}
-	if (IS_TRUE(val)) return 1;
 	return -1;
 }
 

src/core/t-string.c

@@ -326,6 +326,67 @@ static REBSER *make_binary(REBVAL *arg, REBOOL make)
 	return ((int)LO_CASE(*(REBYTE*)v2)) - ((int)LO_CASE(*(REBYTE*)v1));
 }
 
+// WARNING! Not re-entrant. !!!  Must find a way to push it on stack?
+static struct {
+	REBFLG cased;
+	REBFLG reverse;
+	REBCNT offset;
+	REBVAL *compare;
+	REBFLG wide;
+} sort_flags = {0};
+
+/***********************************************************************
+**
+*/	static int Compare_Call(const void *p1, const void *p2)
+/*
+***********************************************************************/
+{
+	REBVAL *v1;
+	REBVAL *v2;
+	REBVAL *val;
+	REBVAL *tmp;
+
+	// O: is there better way how to temporary use 2 values?
+	DS_SKIP; v1 = DS_TOP;
+	DS_SKIP; v2 = DS_TOP;
+
+	if (sort_flags.wide) {
+		SET_CHAR(v1, (int)(*(REBCHR*)p2));
+		SET_CHAR(v2, (int)(*(REBCHR*)p1));
+	} else {
+		SET_CHAR(v1, (int)(*(REBYTE*)p2));
+		SET_CHAR(v2, (int)(*(REBYTE*)p1));
+	}
+	
+	if (sort_flags.reverse) {
+		tmp = v1;
+		v1 = v2;
+		v2 = tmp;
+	}
+
+	val = Apply_Func(0, sort_flags.compare, v1, v2, 0);
+
+	// v1 and v2 no more needed...
+	DS_POP;
+	DS_POP;
+
+	if (IS_LOGIC(val)) {
+		if (IS_TRUE(val)) return 1;
+		return -1;
+	}
+	if (IS_INTEGER(val)) {
+		if (VAL_INT64(val) < 0) return 1;
+		if (VAL_INT64(val) == 0) return 0;
+		return -1;
+	}
+	if (IS_DECIMAL(val)) {
+		if (VAL_DECIMAL(val) < 0) return 1;
+		if (VAL_DECIMAL(val) == 0) return 0;
+		return -1;
+	}
+	return -1;
+}
+
 
 /***********************************************************************
 **
@@ -336,6 +397,7 @@ static REBSER *make_binary(REBVAL *arg, REBOOL make)
 	REBCNT len;
 	REBCNT skip = 1;
 	REBCNT size = 1;
+	REBSER *args;
 	int (*sfunc)(const void *v1, const void *v2);
 
 	// Determine length of sort:
@@ -351,7 +413,23 @@ static REBSER *make_binary(REBVAL *arg, REBOOL make)
 
 	// Use fast quicksort library function:
 	if (skip > 1) len /= skip, size *= skip;
-	if (ccase) {
+
+	if (ANY_FUNC(compv)) {
+		// Check argument types of comparator function.
+		args = VAL_FUNC_ARGS(compv);
+		if (BLK_LEN(args) > 1 && !TYPE_CHECK(BLK_SKIP(args, 1), REB_CHAR))
+			Trap3(RE_EXPECT_ARG, Of_Type(compv), BLK_SKIP(args, 1), Get_Type_Word(REB_CHAR));
+		if (BLK_LEN(args) > 2 && !TYPE_CHECK(BLK_SKIP(args, 2), REB_CHAR))
+			Trap3(RE_EXPECT_ARG, Of_Type(compv), BLK_SKIP(args, 2), Get_Type_Word(REB_CHAR));
+		sort_flags.cased = ccase;
+		sort_flags.reverse = rev;
+		sort_flags.compare = 0;
+		sort_flags.offset = 0;
+		sort_flags.compare = compv;
+		sort_flags.wide = 1 < SERIES_WIDE(VAL_SERIES(string));
+		sfunc = Compare_Call;
+
+	} else if (ccase) {
 		sfunc = rev ? Compare_Chr_Cased_Rev : Compare_Chr_Cased;
 	} else {
 		sfunc = rev ? Compare_Chr_Uncased_Rev : Compare_Chr_Uncased;

src/tests/units/series-test.r3

@@ -568,12 +568,20 @@ Rebol [
 	--assert "ABCDEFabcdef" == sort/case s
 	--assert "AaBbCcDdEeFf" == sort s
 
---test-- "SORT/compare"
+--test-- "SORT/compare block!"
 	;@@ https://github.com/Oldes/Rebol-issues/issues/720
 	--assert [3 2 1] = sort/compare [1 2 3] func [a b] [a > b]
 	;@@ https://github.com/Oldes/Rebol-issues/issues/2376
 	--assert [1 3 10] = sort/compare [1 10 3] func[x y][case [x > y [1] x < y [-1] true [0]]]
 
+--test-- "SORT/compare string!"
+	;@@ https://github.com/Oldes/Rebol-issues/issues/1100
+	comp: func [a b] [a > b]
+	--assert "zyxcba" == sort/compare "abczyx" :comp
+	--assert %54321 == sort/compare %21543 :comp
+	--assert #{050403020100} == sort/compare #{000102030405} :comp
+	--assert "šřba" == sort/compare "ašbř" :comp
+
 --test-- "SORT/skip/compare"
 	;@@ https://github.com/Oldes/Rebol-issues/issues/1152
 	--assert ["A" "a"] = sort/compare ["A" "a"] func [a b] [a < b]