Attachment "tclCmdIL.c-patch" to
ticket [1360413fff]
added by
nobody
2005-11-19 01:41:05.
--- 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
