--- tclCmdIL.c#184	2005-11-18 17:56:20.203046300 +0000
+++ tclCmdIL.c#184-patched	2005-11-18 18:09:26.730144500 +0000
@@ -30,11 +30,33 @@
 
 typedef struct SortElement {
     Tcl_Obj *objPtr;		/* Object being sorted. */
-    int count;			/* number of same elements in list */
-    struct SortElement *nextPtr;/* Next element in the list, or NULL for end
-				 * of list. */
+    struct SortElement *nextPtr;	/* Next element in the list, or
+					 * NULL for end of list. */
+    union {
+	Tcl_Obj *tclObj;
+	char *string;
+	long integer;
+
+/* Storing the double representation can increase the size of the SortElement
+ * not just by another 4 bytes, but also by an extra 4 for padding!
+ * On my system, with it i get sizeof(SortElement)==24, but without it
+ * it's sizeof(SortElement)==16.
+ */
+#define STORE_DOUBLE_REPR 0
+
+#if STORE_DOUBLE_REPR
+	double real;
+#endif
+    } repr;
+
+    int flags;
+
 } SortElement;
 
+#define REPR_NOT_OK    0x01
+#define REPEATED_ELEM  0x02
+
+
 /*
  * These function pointer types are used with the "lsearch" and "lsort"
  * commands to facilitate the "-nocase" option.
@@ -43,6 +65,10 @@
 typedef int (*SortStrCmpFn_t) (const char *, const char *);
 typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t);
 
+struct SortInfo;
+
+typedef int (*SortCompareFn_t) (SortElement *, SortElement *, struct SortInfo *);
+
 /*
  * The "lsort" command needs to pass certain information down to the function
  * that compares two list elements, and the comparison function needs to pass
@@ -3201,6 +3227,11 @@
     };
     SortStrCmpFn_t strCmpFn = strcmp;
 
+Tcl_AppendResult(interp, "XXX lsearch currently broken!", NULL);
+return TCL_ERROR;
+
+
+
     mode = GLOB;
     dataType = ASCII;
     isIncreasing = 1;
@@ -3214,7 +3245,7 @@
     noCase = 0;
     sortInfo.compareCmdPtr = NULL;
     sortInfo.isIncreasing = 0;
-    sortInfo.sortMode = 0;
+    sortInfo.sortMode = SORTMODE_ASCII;
     sortInfo.interp = interp;
     sortInfo.resultCode = TCL_OK;
     sortInfo.indexv = NULL;
@@ -3898,6 +3929,7 @@
     sortInfo.indexc = 0;
     sortInfo.interp = interp;
     sortInfo.resultCode = TCL_OK;
+    sortInfo.sortCompareFn = StringSortCompare;
     cmdPtr = NULL;
     unique = 0;
     indices = 0;
@@ -3909,6 +3941,7 @@
 	switch ((enum Lsort_Switches) index) {
 	case LSORT_ASCII:
 	    sortInfo.sortMode = SORTMODE_ASCII;
+	    sortInfo.sortCompareFn = StringSortCompare;
 	    break;
 	case LSORT_COMMAND:
 	    if (i == (objc-2)) {
@@ -3921,6 +3954,7 @@
 		return TCL_ERROR;
 	    }
 	    sortInfo.sortMode = SORTMODE_COMMAND;
+	    sortInfo.sortCompareFn = CommandSortCompare;
 	    cmdPtr = objv[i+1];
 	    i++;
 	    break;
@@ -3929,6 +3963,7 @@
 	    break;
 	case LSORT_DICTIONARY:
 	    sortInfo.sortMode = SORTMODE_DICTIONARY;
+	    sortInfo.sortCompareFn = StringSortCompare;
 	    break;
 	case LSORT_INCREASING:
 	    sortInfo.isIncreasing = 1;
@@ -3988,12 +4023,14 @@
 	}
 	case LSORT_INTEGER:
 	    sortInfo.sortMode = SORTMODE_INTEGER;
+	    sortInfo.sortCompareFn = IntegerSortCompare;
 	    break;
 	case LSORT_NOCASE:
 	    sortInfo.strCmpFn = strcasecmp;
 	    break;
 	case LSORT_REAL:
 	    sortInfo.sortMode = SORTMODE_REAL;
+	    sortInfo.sortCompareFn = RealSortCompare;
 	    break;
 	case LSORT_UNIQUE:
 	    unique = 1;
@@ -4034,10 +4071,52 @@
 	goto done;
     }
     elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));
-    for (i=0; i < length; i++){
-	elementArray[i].objPtr = listObjPtrs[i];
-	elementArray[i].count = 0;
+    for (i=0; i < length; i++) {
+	Tcl_Obj *list_obj = listObjPtrs[i];
+	elementArray[i].objPtr = list_obj;
+	elementArray[i].flags = 0;
 	elementArray[i].nextPtr = &elementArray[i+1];
+	/*
+	 * Cache the representation of the object to avoid having
+	 *  to do it for every comparison.
+	 */
+	list_obj = SelectObjFromSublist(list_obj, &sortInfo);
+	if (sortInfo.resultCode != TCL_OK) {
+	    elementArray[i].flags |= REPR_NOT_OK;
+	} else {
+	    switch (sortInfo.sortMode) {
+		case SORTMODE_ASCII:
+		case SORTMODE_DICTIONARY:
+		    elementArray[i].repr.string = TclGetString(list_obj);
+		    break;
+		case SORTMODE_INTEGER: {
+		    long l;
+		    if (Tcl_GetLongFromObj(interp, list_obj, &l) != TCL_OK) {
+		      sortInfo.resultCode = TCL_ERROR;
+		      goto cleanup;
+		    }
+		    elementArray[i].repr.integer = l;
+		    break;
+		}
+		case SORTMODE_REAL:
+#if STORE_DOUBLE_REPR
+		{
+		    double d;
+		    if (Tcl_GetDoubleFromObj(interp, list_obj, &d) != TCL_OK) {
+			sortInfo.resultCode = TCL_ERROR;
+			goto cleanup;
+		    }
+		    elementArray[i].repr.real = d;
+		    break;
+		}
+#else
+		/* Same as SORTMODE_COMMAND - store the Tcl_Obj* of the real number to compare. */
+#endif
+		case SORTMODE_COMMAND:
+		    elementArray[i].repr.tclObj = list_obj;
+		    break;
+	    }
+	}
     }
     elementArray[length-1].nextPtr = NULL;
     elementPtr = MergeSort(elementArray, &sortInfo);
@@ -4046,14 +4125,14 @@
 	if (unique) {
 	    if (indices) {
 		for (; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) {
-		    if (elementPtr->count == 0) {
+		    if (!(elementPtr->flags & REPEATED_ELEM)) {
 			Tcl_ListObjAppendElement(interp, resultPtr,
 				Tcl_NewIntObj(elementPtr - &elementArray[0]));
 		    }
 		}
 	    } else {
 		for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr) {
-		    if (elementPtr->count == 0) {
+		    if (!(elementPtr->flags & REPEATED_ELEM)) {
 			Tcl_ListObjAppendElement(interp, resultPtr,
 				elementPtr->objPtr);
 		    }
@@ -4074,6 +4153,8 @@
 	}
 	Tcl_SetObjResult(interp, resultPtr);
     }
+    
+    cleanup:
     ckfree((char*) elementArray);
 
     done:
@@ -4169,6 +4250,8 @@
 {
     SortElement *headPtr;
     SortElement *tailPtr;
+    SortCompareFn_t sortCompare = infoPtr->sortCompareFn;
+    int decreasing = !infoPtr->isIncreasing;
     int cmp;
 
     if (leftPtr == NULL) {
@@ -4177,27 +4260,33 @@
     if (rightPtr == NULL) {
 	return leftPtr;
     }
-    cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr);
+    cmp = sortCompare(leftPtr, rightPtr, infoPtr);
+    if (decreasing) {
+	cmp = -cmp;
+    }
     if (cmp > 0) {
 	tailPtr = rightPtr;
 	rightPtr = rightPtr->nextPtr;
     } else {
 	if (cmp == 0) {
-	    leftPtr->count++;
+	    leftPtr->flags |= REPEATED_ELEM;
 	}
 	tailPtr = leftPtr;
 	leftPtr = leftPtr->nextPtr;
     }
     headPtr = tailPtr;
     while ((leftPtr != NULL) && (rightPtr != NULL)) {
-	cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr);
+	cmp = sortCompare(leftPtr, rightPtr, infoPtr);
+	if (decreasing) {
+	    cmp = -cmp;
+	}
 	if (cmp > 0) {
 	    tailPtr->nextPtr = rightPtr;
 	    tailPtr = rightPtr;
 	    rightPtr = rightPtr->nextPtr;
 	} else {
 	    if (cmp == 0) {
-		leftPtr->count++;
+		leftPtr->flags |= REPEATED_ELEM;
 	    }
 	    tailPtr->nextPtr = leftPtr;
 	    tailPtr = leftPtr;
@@ -4336,6 +4425,194 @@
     return order;
 }
 
+static int
+IntegerSortCompare(
+    SortElement *sortElemPtr1,
+    SortElement *sortElemPtr2,
+    SortInfo *infoPtr)
+{
+    long a, b;
+
+    if (infoPtr->resultCode != TCL_OK
+	|| (sortElemPtr1->flags & REPR_NOT_OK)
+	|| (sortElemPtr2->flags & REPR_NOT_OK)) {
+	/*
+	 * 1. Once an error has occurred, skip any future comparisons so
+	 * as to preserve the error message in sortInterp->result.
+	 * 2. If one or both of the objects have a incorrect representation
+	 *    then compare them equal.
+	 */
+	return 0;
+    }
+
+    a = sortElemPtr1->repr.integer;
+    b = sortElemPtr2->repr.integer;
+    if (a > b) {
+	return 1;
+    } else if (b > a) {
+	return -1;
+    }
+    return 0;
+}
+
+#if STORE_DOUBLE_REPR
+static int
+RealSortCompare(
+    SortElement *sortElemPtr1,
+    SortElement *sortElemPtr2,
+    SortInfo *infoPtr)
+{
+    double a, b;
+
+    if (infoPtr->resultCode != TCL_OK
+	|| (sortElemPtr1->flags & REPR_NOT_OK)
+	|| (sortElemPtr2->flags & REPR_NOT_OK)) {
+	/*
+	 * Once an error has occurred, skip any future comparisons so
+	 * as to preserve the error message in sortInterp->result.
+	 */
+	return 0;
+    }
+    a = sortElemPtr1->repr.real;
+    b = sortElemPtr2->repr.real;
+
+    if (a > b) {
+        return 1;
+    } else if (b > a) {
+        return -1;
+    }
+    return 0;
+}
+
+#else
+
+static int
+RealSortCompare(
+    SortElement *sortElemPtr1,
+    SortElement *sortElemPtr2,
+    SortInfo *infoPtr)
+{
+    Tcl_Obj *tclObj_a, *tclObj_b;
+    double a, b;
+
+    if (infoPtr->resultCode != TCL_OK) {
+	/*
+	 * Once an error has occurred, skip any future comparisons so
+	 * as to preserve the error message in sortInterp->result.
+	 */
+	return 0;
+    }
+
+    tclObj_a = sortElemPtr1->repr.tclObj;
+    tclObj_b = sortElemPtr2->repr.tclObj;
+
+    if (
+	(Tcl_GetDoubleFromObj(infoPtr->interp, tclObj_a, &a) != TCL_OK)
+	    ||
+	(Tcl_GetDoubleFromObj(infoPtr->interp, tclObj_b, &b) != TCL_OK)
+    ) {
+	infoPtr->resultCode = TCL_ERROR;
+	return 0;
+    }
+
+    if (a > b) {
+        return 1;
+    } else if (b > a) {
+        return -1;
+    }
+    return 0;
+}
+
+#endif /* STORE_DOUBLE_REPR */
+
+
+static int
+StringSortCompare(
+    SortElement *sortElemPtr1,
+    SortElement *sortElemPtr2,
+    SortInfo *infoPtr)
+{
+    char *a, *b;
+    
+    if (infoPtr->resultCode != TCL_OK
+	|| (sortElemPtr1->flags & REPR_NOT_OK)
+	|| (sortElemPtr2->flags & REPR_NOT_OK)) {
+	/*
+	 * Once an error has occurred, skip any future comparisons so
+	 * as to preserve the error message in sortInterp->result.
+	 */
+	return 0;
+    }
+
+    a = sortElemPtr1->repr.string;
+    b = sortElemPtr2->repr.string;
+    
+    if (infoPtr->sortMode == SORTMODE_ASCII) {
+	return infoPtr->strCmpFn(a, b);
+    } else { /* SORTMODE_DICTIONARY */
+	return DictionaryCompare(a, b);
+    }
+}
+
+static int
+CommandSortCompare(
+    SortElement *sortElemPtr1,
+    SortElement *sortElemPtr2,
+    SortInfo *infoPtr)
+{
+    int order;
+    Tcl_Obj **objv, *paramObjv[2];
+    int objc;
+
+    if (infoPtr->resultCode != TCL_OK
+	|| (sortElemPtr1->flags & REPR_NOT_OK)
+	|| (sortElemPtr2->flags & REPR_NOT_OK)) {
+
+	/*
+	 * Once an error has occurred, skip any future comparisons so
+	 * as to preserve the error message in sortInterp->result.
+	 */
+	return 0;
+    }
+
+    paramObjv[0] = sortElemPtr1->repr.tclObj; /* a */
+    paramObjv[1] = sortElemPtr2->repr.tclObj; /* b */
+
+    /*
+     * We made space in the command list for the two things to
+     * compare. Replace them and evaluate the result.
+     */
+    
+    Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
+    Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2,
+	    2, 2, paramObjv);
+    Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr,
+	    &objc, &objv);
+    
+    infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0);
+    
+    if (infoPtr->resultCode != TCL_OK) {
+	Tcl_AddErrorInfo(infoPtr->interp,
+		"\n    (-compare command)");
+        return 0;
+    }
+    
+    /*
+     * Parse the result of the command.
+     */
+    order = 0;
+    if (Tcl_GetIntFromObj(infoPtr->interp,
+	    Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
+	Tcl_ResetResult(infoPtr->interp);
+	Tcl_AppendResult(infoPtr->interp,
+	    "-compare command returned non-integer result", NULL);
+	infoPtr->resultCode = TCL_ERROR;
+	return 0;
+    }
+    return order;
+}
+
+
 /*
  *----------------------------------------------------------------------
  *

    
##############################################################

# lsort testcase 

set ::REAL 1

set out "lsort_test_results.[clock clicks]"
puts "OUT: $out"

set fout [open $out w]

proc store { lst } {
	flush stdout
	foreach _ $lst {
		puts $::fout $_
	}
}

# INDEX BIG list
set list_of_lists {}
for {set j 0 ; set i 1} {$i < 100000} {incr i} {
	lappend list_of_lists [list [incr j] [incr j] [incr j]]
}

puts [time { set sorted_lines [lsort -index 2 -integer $list_of_lists] } 5]
puts $fout "Test #1"
store $sorted_lines
puts [time { set sorted_lines [lsort -index 1 -dictionary -decreasing $list_of_lists] } 5]
puts $fout "Test #2"
store $sorted_lines
puts [time { set sorted_lines [lsort -index 1 -ascii $list_of_lists] } 5]
puts $fout "Test #3"
store $sorted_lines
if {$::REAL} {
 puts [time { set sorted_lines [lsort -index 1 -real $list_of_lists] } 5]
 puts $fout "Test #4"
 store $sorted_lines
}
puts [time { set sorted_lines [lsort -ascii $list_of_lists] } 5]
puts $fout "Test #5"
store $sorted_lines
puts [time { set sorted_lines [lsort -dictionary $list_of_lists] } 5]
puts $fout "Test #6"
store $sorted_lines


# -unique

puts [time { set sorted_lines [lsort -unique -index 2 -integer $list_of_lists] } 5]
puts $fout "Test #7"
store $sorted_lines
if {$::REAL} {
 puts [time { set sorted_lines [lsort -unique -index 2 -real $list_of_lists] } 5]
 puts $fout "Test #8"
 store $sorted_lines
}
puts [time { set sorted_lines [lsort -unique -index 1 -dictionary $list_of_lists] } 5]
puts $fout "Test #9"
store $sorted_lines
puts [time { set sorted_lines [lsort -unique -index 1 -ascii $list_of_lists] } 5]
puts $fout "Test #10"
store $sorted_lines
puts [time { set sorted_lines [lsort -unique -ascii $list_of_lists] } 5]
puts $fout "Test #11"
store $sorted_lines
puts [time { set sorted_lines [lsort -unique -dictionary $list_of_lists] } 5]
puts $fout "Test #12"
store $sorted_lines

# small stuff
set small_lst {1 2 3 4 5 6 7 8 9 0 a b c d 2 3 4 5 6}
set num_lst {1 2 3 4 5 6 7 8 9 0  3 4 5 6 4543 543543 53453}
puts [time { set sorted_lines [lsort -unique -dictionary $small_lst] } 500]
puts $fout "Test #13"
store $sorted_lines
puts [time { set sorted_lines [lsort -unique $small_lst] } 1000]
puts $fout "Test #14"
store $sorted_lines
puts [time { set sorted_lines [lsort -unique -ascii $small_lst] } 1000]
puts $fout "Test #15"
store $sorted_lines
puts [time { set sorted_lines [lsort -unique -integer $num_lst] } 1000]
puts $fout "Test #16"
store $sorted_lines
if {$::REAL} {
 puts [time { set sorted_lines [lsort -unique -real $num_lst] } 1000]
 puts $fout "Test #17"
 store $sorted_lines
}
puts [time { set sorted_lines [lsort -unique -ascii $num_lst] } 1000]
puts $fout "Test #18"
store $sorted_lines
puts [time { set sorted_lines [lsort -unique -dictionary $num_lst] } 1000]
puts $fout "Test #19"
store $sorted_lines


# INTGERE LIST
set big_num_lst {}
for {set i 1} {$i < 1000000} {incr i} {
	lappend big_num_lst $i
	lappend big_num_lst -$i
}
puts [time { set sorted_lines [lsort -unique -integer $big_num_lst] } ]
puts $fout "Test #20"
store $sorted_lines
if {$::REAL} {
 puts [time { set sorted_lines [lsort -unique -real $big_num_lst] } ]
 puts $fout "Test #20"
 store $sorted_lines
}
puts [time { set sorted_lines [lsort -unique -ascii $big_num_lst] } ]
puts $fout "Test #20"
store $sorted_lines


# REAL LIST
set big_num_lst {}
for {set i 1} {$i < 1000} {incr i} {
	lappend big_num_lst $i.$i
	lappend big_num_lst -$i.$i
}
if {$::REAL} {
 puts [time { set sorted_lines [lsort -unique -real $big_num_lst] } ]
 puts $fout "Test #21"
 store $sorted_lines
 puts [time { set sorted_lines [lsort -unique -real {1 2 3 4 5 6 7 8 9} ] } 10000]
 puts $fout "Test #22"
 store $sorted_lines
 puts [time { set sorted_lines [lsort -unique -real {9 8 7 6 5 4 3 2 1} ] } 10000]
 puts $fout "Test #23"
 store $sorted_lines
 puts [time { set sorted_lines [lsort -unique -real {9.1 8.1 7.1 6.1 5.1 4.1 3.1 2.1 1.1} ] } 10000]
 puts $fout "Test #24"
 store $sorted_lines
 puts [time { set sorted_lines [lsort -unique -real -decreasing {9.1 8.1 7.1 6.1 5.1 4.1 3.1 2.1 1.1} ] } 10000]
 puts $fout "Test #25"
 store $sorted_lines
 puts [time { set sorted_lines [lsort -unique -real {1.1 0.1 99 -1.1} ] } 1000000]
 puts $fout "Test #26"
 store $sorted_lines
}

# BIG FILE

set f $::argv0

set fin [open $f r]
set lines {}
while {[gets $fin line] >= 0} {
	lappend lines $line
	if {[llength $lines] < 1000000} {
		eval lappend lines $lines
	}
}
close $fin

puts $fout "Test #27    Lines = [llength $lines]"
puts [time {
	set sorted_lines [lsort $lines]
} 1]
store $sorted_lines
puts $fout "Test #28    Lines = [llength $lines]"
puts [time {
	set sorted_lines [lsort -decreasing $lines]
} 1]
store $sorted_lines
puts $fout "Test #29    Lines = [llength $lines]"
puts [time {
	set sorted_lines [lsort -decreasing -dictionary $lines]
} 1]
store $sorted_lines


close $::fout
  
  
  
  
  