View Issue Details

IDProjectCategoryView StatusLast Update
0035558pas2jsrtlpublic2020-02-08 10:53
ReportersilvioprogAssigned ToMichael Van Canneyt 
PrioritynormalSeverityminorReproducibilityhave not tried
Status resolvedResolutionfixed 
Product VersionProduct Build 
Target VersionFixed in Versiontrunk 
Summary0035558: [PATCH] Added type TListSortCompareFunc (for Delphi compatibility)
DescriptionHello.

Patch in attachment.

Thank you!
Additional InformationReference: http://docwiki.embarcadero.com/Libraries/Rio/en/System.Classes.TListSortCompareFunc
TagsNo tags attached.
Fixed in Revision672
Attached Files
  • 00001-classes.pas.diff (3,525 bytes)
    Index: packages/rtl/classes.pas
    ===================================================================
    --- packages/rtl/classes.pas	(revision 472)
    +++ packages/rtl/classes.pas	(working copy)
    @@ -46,6 +46,7 @@
     
       TListAssignOp = (laCopy, laAnd, laOr, laXor, laSrcUnique, laDestUnique);
       TListSortCompare = function(Item1, Item2: JSValue): Integer;
    +  TListSortCompareFunc = reference to function (Item1, Item2: Pointer): Integer;
       TListCallback = Types.TListCallback;
       TListStaticCallback = Types.TListStaticCallback;
       TAlignment = (taLeftJustify, taRightJustify, taCenter);
    @@ -108,6 +109,7 @@
         function Remove(Item: JSValue): Integer;
         procedure Pack;
         procedure Sort(const Compare: TListSortCompare);
    +    procedure SortList(const Compare: TListSortCompareFunc);
         procedure ForEachCall(const proc2call: TListCallback; const arg: JSValue);
         procedure ForEachCall(const proc2call: TListStaticCallback; const arg: JSValue);
         property Capacity: Integer read FCapacity write SetCapacity;
    @@ -176,6 +178,7 @@
         function Remove(Item: JSValue): Integer;
         procedure Pack;
         procedure Sort(const Compare: TListSortCompare);
    +    procedure SortList(const Compare: TListSortCompareFunc);
         property Capacity: Integer read GetCapacity write SetCapacity;
         property Count: Integer read GetCount write SetCount;
         property Items[Index: Integer]: JSValue read Get write Put; default;
    @@ -445,6 +448,7 @@
       TCollectionItemClass = class of TCollectionItem;
       TCollectionNotification = (cnAdded, cnExtracting, cnDeleting);
       TCollectionSortCompare = function (Item1, Item2: TCollectionItem): Integer;
    +  TCollectionSortCompareFunc = reference to function (Item1, Item2: TCollectionItem): Integer;
     
       TCollection = class(TPersistent)
       private
    @@ -488,6 +492,7 @@
         function FindItemID(ID: Integer): TCollectionItem;
         procedure Exchange(Const Index1, index2: integer);
         procedure Sort(Const Compare : TCollectionSortCompare);
    +    procedure Sort(Const Compare : TCollectionSortCompareFunc);
         property Count: Integer read GetCount;
         property ItemClass: TCollectionItemClass read FItemClass;
         property Items[Index: Integer]: TCollectionItem read GetItem write SetItem;
    @@ -1075,7 +1080,7 @@
     // Needed by Sort method.
     
     Procedure QuickSort(aList: TJSValueDynArray; L, R : Longint;
    -                    const Compare: TListSortCompare);
    +                    const Compare: TListSortCompareFunc);
     var
       I, J : Longint;
       P, Q : JSValue;
    @@ -1119,6 +1124,16 @@
     procedure TFPList.Sort(const Compare: TListSortCompare);
     begin
       if Not Assigned(FList) or (FCount < 2) then exit;
    +  QuickSort(Flist, 0, FCount-1,
    +    function(Item1, Item2: Pointer): Integer
    +    begin
    +      Result := Compare(Item1, Item2);
    +    end);
    +end;
    +
    +procedure TFPList.SortList(const Compare: TListSortCompareFunc);
    +begin
    +  if Not Assigned(FList) or (FCount < 2) then exit;
       QuickSort(Flist, 0, FCount-1, Compare);
     end;
     
    @@ -1466,6 +1481,11 @@
       FList.Sort(Compare);
     end;
     
    +procedure TList.SortList(const Compare: TListSortCompareFunc);
    +begin
    +  FList.SortList(Compare);
    +end;
    +
     { TPersistent }
     
     procedure TPersistent.AssignError(Source: TPersistent);
    @@ -3200,6 +3220,17 @@
       end;
     end;
     
    +procedure TCollection.SortList(const Compare: TCollectionSortCompareFunc);
    +
    +begin
    +  BeginUpdate;
    +  try
    +    FItems.SortList(TCollectionSortCompareFunc(Compare));
    +  Finally
    +    EndUpdate;
    +  end;
    +end;
    +
     procedure TCollection.Exchange(Const Index1, index2: integer);
     
     begin
    
    00001-classes.pas.diff (3,525 bytes)
  • 0002-classes.pas.diff (3,525 bytes)
    Index: packages/rtl/classes.pas
    ===================================================================
    --- packages/rtl/classes.pas	(revision 472)
    +++ packages/rtl/classes.pas	(working copy)
    @@ -46,6 +46,7 @@
     
       TListAssignOp = (laCopy, laAnd, laOr, laXor, laSrcUnique, laDestUnique);
       TListSortCompare = function(Item1, Item2: JSValue): Integer;
    +  TListSortCompareFunc = reference to function (Item1, Item2: JSValue): Integer;
       TListCallback = Types.TListCallback;
       TListStaticCallback = Types.TListStaticCallback;
       TAlignment = (taLeftJustify, taRightJustify, taCenter);
    @@ -108,6 +109,7 @@
         function Remove(Item: JSValue): Integer;
         procedure Pack;
         procedure Sort(const Compare: TListSortCompare);
    +    procedure SortList(const Compare: TListSortCompareFunc);
         procedure ForEachCall(const proc2call: TListCallback; const arg: JSValue);
         procedure ForEachCall(const proc2call: TListStaticCallback; const arg: JSValue);
         property Capacity: Integer read FCapacity write SetCapacity;
    @@ -176,6 +178,7 @@
         function Remove(Item: JSValue): Integer;
         procedure Pack;
         procedure Sort(const Compare: TListSortCompare);
    +    procedure SortList(const Compare: TListSortCompareFunc);
         property Capacity: Integer read GetCapacity write SetCapacity;
         property Count: Integer read GetCount write SetCount;
         property Items[Index: Integer]: JSValue read Get write Put; default;
    @@ -445,6 +448,7 @@
       TCollectionItemClass = class of TCollectionItem;
       TCollectionNotification = (cnAdded, cnExtracting, cnDeleting);
       TCollectionSortCompare = function (Item1, Item2: TCollectionItem): Integer;
    +  TCollectionSortCompareFunc = reference to function (Item1, Item2: TCollectionItem): Integer;
     
       TCollection = class(TPersistent)
       private
    @@ -488,6 +492,7 @@
         function FindItemID(ID: Integer): TCollectionItem;
         procedure Exchange(Const Index1, index2: integer);
         procedure Sort(Const Compare : TCollectionSortCompare);
    +    procedure Sort(Const Compare : TCollectionSortCompareFunc);
         property Count: Integer read GetCount;
         property ItemClass: TCollectionItemClass read FItemClass;
         property Items[Index: Integer]: TCollectionItem read GetItem write SetItem;
    @@ -1075,7 +1080,7 @@
     // Needed by Sort method.
     
     Procedure QuickSort(aList: TJSValueDynArray; L, R : Longint;
    -                    const Compare: TListSortCompare);
    +                    const Compare: TListSortCompareFunc);
     var
       I, J : Longint;
       P, Q : JSValue;
    @@ -1119,6 +1124,16 @@
     procedure TFPList.Sort(const Compare: TListSortCompare);
     begin
       if Not Assigned(FList) or (FCount < 2) then exit;
    +  QuickSort(Flist, 0, FCount-1,
    +    function(Item1, Item2: JSValue): Integer
    +    begin
    +      Result := Compare(Item1, Item2);
    +    end);
    +end;
    +
    +procedure TFPList.SortList(const Compare: TListSortCompareFunc);
    +begin
    +  if Not Assigned(FList) or (FCount < 2) then exit;
       QuickSort(Flist, 0, FCount-1, Compare);
     end;
     
    @@ -1466,6 +1481,11 @@
       FList.Sort(Compare);
     end;
     
    +procedure TList.SortList(const Compare: TListSortCompareFunc);
    +begin
    +  FList.SortList(Compare);
    +end;
    +
     { TPersistent }
     
     procedure TPersistent.AssignError(Source: TPersistent);
    @@ -3200,6 +3220,17 @@
       end;
     end;
     
    +procedure TCollection.SortList(const Compare: TCollectionSortCompareFunc);
    +
    +begin
    +  BeginUpdate;
    +  try
    +    FItems.SortList(TCollectionSortCompareFunc(Compare));
    +  Finally
    +    EndUpdate;
    +  end;
    +end;
    +
     procedure TCollection.Exchange(Const Index1, index2: integer);
     
     begin
    
    0002-classes.pas.diff (3,525 bytes)

Activities

silvioprog

2019-05-10 17:26

reporter  

00001-classes.pas.diff (3,525 bytes)
Index: packages/rtl/classes.pas
===================================================================
--- packages/rtl/classes.pas	(revision 472)
+++ packages/rtl/classes.pas	(working copy)
@@ -46,6 +46,7 @@
 
   TListAssignOp = (laCopy, laAnd, laOr, laXor, laSrcUnique, laDestUnique);
   TListSortCompare = function(Item1, Item2: JSValue): Integer;
+  TListSortCompareFunc = reference to function (Item1, Item2: Pointer): Integer;
   TListCallback = Types.TListCallback;
   TListStaticCallback = Types.TListStaticCallback;
   TAlignment = (taLeftJustify, taRightJustify, taCenter);
@@ -108,6 +109,7 @@
     function Remove(Item: JSValue): Integer;
     procedure Pack;
     procedure Sort(const Compare: TListSortCompare);
+    procedure SortList(const Compare: TListSortCompareFunc);
     procedure ForEachCall(const proc2call: TListCallback; const arg: JSValue);
     procedure ForEachCall(const proc2call: TListStaticCallback; const arg: JSValue);
     property Capacity: Integer read FCapacity write SetCapacity;
@@ -176,6 +178,7 @@
     function Remove(Item: JSValue): Integer;
     procedure Pack;
     procedure Sort(const Compare: TListSortCompare);
+    procedure SortList(const Compare: TListSortCompareFunc);
     property Capacity: Integer read GetCapacity write SetCapacity;
     property Count: Integer read GetCount write SetCount;
     property Items[Index: Integer]: JSValue read Get write Put; default;
@@ -445,6 +448,7 @@
   TCollectionItemClass = class of TCollectionItem;
   TCollectionNotification = (cnAdded, cnExtracting, cnDeleting);
   TCollectionSortCompare = function (Item1, Item2: TCollectionItem): Integer;
+  TCollectionSortCompareFunc = reference to function (Item1, Item2: TCollectionItem): Integer;
 
   TCollection = class(TPersistent)
   private
@@ -488,6 +492,7 @@
     function FindItemID(ID: Integer): TCollectionItem;
     procedure Exchange(Const Index1, index2: integer);
     procedure Sort(Const Compare : TCollectionSortCompare);
+    procedure Sort(Const Compare : TCollectionSortCompareFunc);
     property Count: Integer read GetCount;
     property ItemClass: TCollectionItemClass read FItemClass;
     property Items[Index: Integer]: TCollectionItem read GetItem write SetItem;
@@ -1075,7 +1080,7 @@
 // Needed by Sort method.
 
 Procedure QuickSort(aList: TJSValueDynArray; L, R : Longint;
-                    const Compare: TListSortCompare);
+                    const Compare: TListSortCompareFunc);
 var
   I, J : Longint;
   P, Q : JSValue;
@@ -1119,6 +1124,16 @@
 procedure TFPList.Sort(const Compare: TListSortCompare);
 begin
   if Not Assigned(FList) or (FCount < 2) then exit;
+  QuickSort(Flist, 0, FCount-1,
+    function(Item1, Item2: Pointer): Integer
+    begin
+      Result := Compare(Item1, Item2);
+    end);
+end;
+
+procedure TFPList.SortList(const Compare: TListSortCompareFunc);
+begin
+  if Not Assigned(FList) or (FCount < 2) then exit;
   QuickSort(Flist, 0, FCount-1, Compare);
 end;
 
@@ -1466,6 +1481,11 @@
   FList.Sort(Compare);
 end;
 
+procedure TList.SortList(const Compare: TListSortCompareFunc);
+begin
+  FList.SortList(Compare);
+end;
+
 { TPersistent }
 
 procedure TPersistent.AssignError(Source: TPersistent);
@@ -3200,6 +3220,17 @@
   end;
 end;
 
+procedure TCollection.SortList(const Compare: TCollectionSortCompareFunc);
+
+begin
+  BeginUpdate;
+  try
+    FItems.SortList(TCollectionSortCompareFunc(Compare));
+  Finally
+    EndUpdate;
+  end;
+end;
+
 procedure TCollection.Exchange(Const Index1, index2: integer);
 
 begin
00001-classes.pas.diff (3,525 bytes)

silvioprog

2019-05-11 17:06

reporter   ~0116134

Please consider using only this last patch "0002-classes.pas.diff". (I don't have permission to edit files on mantis)

0002-classes.pas.diff (3,525 bytes)
Index: packages/rtl/classes.pas
===================================================================
--- packages/rtl/classes.pas	(revision 472)
+++ packages/rtl/classes.pas	(working copy)
@@ -46,6 +46,7 @@
 
   TListAssignOp = (laCopy, laAnd, laOr, laXor, laSrcUnique, laDestUnique);
   TListSortCompare = function(Item1, Item2: JSValue): Integer;
+  TListSortCompareFunc = reference to function (Item1, Item2: JSValue): Integer;
   TListCallback = Types.TListCallback;
   TListStaticCallback = Types.TListStaticCallback;
   TAlignment = (taLeftJustify, taRightJustify, taCenter);
@@ -108,6 +109,7 @@
     function Remove(Item: JSValue): Integer;
     procedure Pack;
     procedure Sort(const Compare: TListSortCompare);
+    procedure SortList(const Compare: TListSortCompareFunc);
     procedure ForEachCall(const proc2call: TListCallback; const arg: JSValue);
     procedure ForEachCall(const proc2call: TListStaticCallback; const arg: JSValue);
     property Capacity: Integer read FCapacity write SetCapacity;
@@ -176,6 +178,7 @@
     function Remove(Item: JSValue): Integer;
     procedure Pack;
     procedure Sort(const Compare: TListSortCompare);
+    procedure SortList(const Compare: TListSortCompareFunc);
     property Capacity: Integer read GetCapacity write SetCapacity;
     property Count: Integer read GetCount write SetCount;
     property Items[Index: Integer]: JSValue read Get write Put; default;
@@ -445,6 +448,7 @@
   TCollectionItemClass = class of TCollectionItem;
   TCollectionNotification = (cnAdded, cnExtracting, cnDeleting);
   TCollectionSortCompare = function (Item1, Item2: TCollectionItem): Integer;
+  TCollectionSortCompareFunc = reference to function (Item1, Item2: TCollectionItem): Integer;
 
   TCollection = class(TPersistent)
   private
@@ -488,6 +492,7 @@
     function FindItemID(ID: Integer): TCollectionItem;
     procedure Exchange(Const Index1, index2: integer);
     procedure Sort(Const Compare : TCollectionSortCompare);
+    procedure Sort(Const Compare : TCollectionSortCompareFunc);
     property Count: Integer read GetCount;
     property ItemClass: TCollectionItemClass read FItemClass;
     property Items[Index: Integer]: TCollectionItem read GetItem write SetItem;
@@ -1075,7 +1080,7 @@
 // Needed by Sort method.
 
 Procedure QuickSort(aList: TJSValueDynArray; L, R : Longint;
-                    const Compare: TListSortCompare);
+                    const Compare: TListSortCompareFunc);
 var
   I, J : Longint;
   P, Q : JSValue;
@@ -1119,6 +1124,16 @@
 procedure TFPList.Sort(const Compare: TListSortCompare);
 begin
   if Not Assigned(FList) or (FCount < 2) then exit;
+  QuickSort(Flist, 0, FCount-1,
+    function(Item1, Item2: JSValue): Integer
+    begin
+      Result := Compare(Item1, Item2);
+    end);
+end;
+
+procedure TFPList.SortList(const Compare: TListSortCompareFunc);
+begin
+  if Not Assigned(FList) or (FCount < 2) then exit;
   QuickSort(Flist, 0, FCount-1, Compare);
 end;
 
@@ -1466,6 +1481,11 @@
   FList.Sort(Compare);
 end;
 
+procedure TList.SortList(const Compare: TListSortCompareFunc);
+begin
+  FList.SortList(Compare);
+end;
+
 { TPersistent }
 
 procedure TPersistent.AssignError(Source: TPersistent);
@@ -3200,6 +3220,17 @@
   end;
 end;
 
+procedure TCollection.SortList(const Compare: TCollectionSortCompareFunc);
+
+begin
+  BeginUpdate;
+  try
+    FItems.SortList(TCollectionSortCompareFunc(Compare));
+  Finally
+    EndUpdate;
+  end;
+end;
+
 procedure TCollection.Exchange(Const Index1, index2: integer);
 
 begin
0002-classes.pas.diff (3,525 bytes)

Michael Van Canneyt

2020-02-08 10:53

administrator   ~0120939

Applied, but I had to do some fixes: your implementation for TCollection was wrong, the code didn't even compile.

When you do such a change, make sure you test all calls or at least disable optimization:
if the newly added code is not called, the compiler will not attempt to compile it and thus you may be left with an error.
As an alternative, compile the unit directly on the command-line (this is equivalent to disabling optimization)

Anyway, thanks for the patch!

Issue History

Date Modified Username Field Change
2019-05-10 17:26 silvioprog New Issue
2019-05-10 17:26 silvioprog File Added: 00001-classes.pas.diff
2019-05-11 17:06 silvioprog File Added: 0002-classes.pas.diff
2019-05-11 17:06 silvioprog Note Added: 0116134
2020-02-08 10:53 Michael Van Canneyt Assigned To => Michael Van Canneyt
2020-02-08 10:53 Michael Van Canneyt Status new => resolved
2020-02-08 10:53 Michael Van Canneyt Resolution open => fixed
2020-02-08 10:53 Michael Van Canneyt Fixed in Version => trunk
2020-02-08 10:53 Michael Van Canneyt Fixed in Revision => 672
2020-02-08 10:53 Michael Van Canneyt Note Added: 0120939