View Issue Details

IDProjectCategoryView StatusLast Update
0035962FPCRTLpublic2019-08-30 09:34
ReporterOndrej PokornyAssigned ToMichael Van Canneyt 
PrioritynormalSeverityminorReproducibilityalways
Status closedResolutionfixed 
Product Version3.3.1Product Build 
Target VersionFixed in Version3.3.1 
Summary0035962: Enable Sort() with context in TFPList and TList
DescriptionUnit sortbase supports sorting with a custom "Context" parameter. Yet it is not enabled in TFPList and TList.

The attached patch adds Sort() overloads with this Context parameter to TFPList and TList.
Steps To Reproduceprogram Project1;

{$mode delphi}

uses Contnrs, Math;

type
  TItem = class
  public
    Value: Integer;
    constructor Create(aValue: Integer);
  end;
  TSortParameter = class
  public
    Desc: Boolean;
  end;

{ TItem }

constructor TItem.Create(aValue: Integer);
begin
  inherited Create;
  Value := aValue;
end;

procedure WritelnItems(L: TObjectList);
var
  I: TItem;
begin
  for I in L do
    Writeln(I.Value);
end;

function Compare(Item1, Item2, Context: Pointer): Integer;
var
  xItem1: TItem absolute Item1;
  xItem2: TItem absolute Item2;
  xParam: TSortParameter absolute Context;
begin
  Result := CompareValue(xItem1.Value, xItem2.Value);
  if xParam.Desc then
    Result := -Result;
end;

var
  L: TObjectList;
  I: Integer;
  B: Boolean;
  P: TSortParameter;
const
  AscDesc: array[Boolean] of string = ('ASC', 'DESC');
begin
  L := TObjectList.Create;
  for I := 1 to 5 do
    L.Add(TItem.Create(I));
  P := TSortParameter.Create;
  for B in Boolean do
  begin
    Writeln(AscDesc[B]);
    P.Desc := B;
    L.Sort(Compare, P);
    WritelnItems(L);
    Writeln;
  end;
  P.Free;
  L.Free;
  ReadLn;
end.
TagsNo tags attached.
Fixed in Revision42798
FPCOldBugId
FPCTarget3.2.0
Attached Files
  • list-sort-context-01.patch (2,500 bytes)
    Index: rtl/objpas/classes/classesh.inc
    ===================================================================
    --- rtl/objpas/classes/classesh.inc	(revision 42655)
    +++ rtl/objpas/classes/classesh.inc	(working copy)
    @@ -256,6 +256,8 @@
         procedure Pack;
         procedure Sort(Compare: TListSortCompare);
         procedure Sort(Compare: TListSortCompare; SortingAlgorithm: PSortingAlgorithm);
    +    procedure Sort(Compare: TListSortComparer_Context; Context: Pointer);
    +    procedure Sort(Compare: TListSortComparer_Context; Context: Pointer; SortingAlgorithm: PSortingAlgorithm);
         procedure ForEachCall(proc2call:TListCallback;arg:pointer);
         procedure ForEachCall(proc2call:TListStaticCallback;arg:pointer);
         property Capacity: Integer read FCapacity write SetCapacity;
    @@ -342,6 +344,8 @@
         procedure Pack;
         procedure Sort(Compare: TListSortCompare);
         procedure Sort(Compare: TListSortCompare; SortingAlgorithm: PSortingAlgorithm);
    +    procedure Sort(Compare: TListSortComparer_Context; Context: Pointer);
    +    procedure Sort(Compare: TListSortComparer_Context; Context: Pointer; SortingAlgorithm: PSortingAlgorithm);
         property Capacity: Integer read GetCapacity write SetCapacity;
         property Count: Integer read GetCount write SetCount;
         property Items[Index: Integer]: Pointer read Get write Put; default;
    Index: rtl/objpas/classes/lists.inc
    ===================================================================
    --- rtl/objpas/classes/lists.inc	(revision 42655)
    +++ rtl/objpas/classes/lists.inc	(working copy)
    @@ -312,6 +312,18 @@
     end;
     
     
    +procedure TFPList.Sort(Compare: TListSortComparer_Context; Context: Pointer);
    +begin
    +  Sort(Compare, Context, SortBase.DefaultSortingAlgorithm);
    +end;
    +
    +
    +procedure TFPList.Sort(Compare: TListSortComparer_Context; Context: Pointer; SortingAlgorithm: PSortingAlgorithm);
    +begin
    +  SortingAlgorithm^.PtrListSorter_ContextComparer(PPointer(FList), FCount, Compare, Context);
    +end;
    +
    +
     procedure TFPList.ForEachCall(proc2call:TListCallback;arg:pointer);
     var
       i : integer;
    @@ -784,6 +796,16 @@
       FList.Sort(Compare, SortingAlgorithm);
     end;
     
    +procedure TList.Sort(Compare: TListSortComparer_Context; Context: Pointer);
    +begin
    +  FList.Sort(Compare, Context);
    +end;
    +
    +procedure TList.Sort(Compare: TListSortComparer_Context; Context: Pointer; SortingAlgorithm: PSortingAlgorithm);
    +begin
    +  FList.Sort(Compare, Context, SortingAlgorithm);
    +end;
    +
     procedure TList.CopyMove (aList : TList);
     var r : integer;
     begin
    

Activities

Ondrej Pokorny

2019-08-14 07:31

reporter  

list-sort-context-01.patch (2,500 bytes)
Index: rtl/objpas/classes/classesh.inc
===================================================================
--- rtl/objpas/classes/classesh.inc	(revision 42655)
+++ rtl/objpas/classes/classesh.inc	(working copy)
@@ -256,6 +256,8 @@
     procedure Pack;
     procedure Sort(Compare: TListSortCompare);
     procedure Sort(Compare: TListSortCompare; SortingAlgorithm: PSortingAlgorithm);
+    procedure Sort(Compare: TListSortComparer_Context; Context: Pointer);
+    procedure Sort(Compare: TListSortComparer_Context; Context: Pointer; SortingAlgorithm: PSortingAlgorithm);
     procedure ForEachCall(proc2call:TListCallback;arg:pointer);
     procedure ForEachCall(proc2call:TListStaticCallback;arg:pointer);
     property Capacity: Integer read FCapacity write SetCapacity;
@@ -342,6 +344,8 @@
     procedure Pack;
     procedure Sort(Compare: TListSortCompare);
     procedure Sort(Compare: TListSortCompare; SortingAlgorithm: PSortingAlgorithm);
+    procedure Sort(Compare: TListSortComparer_Context; Context: Pointer);
+    procedure Sort(Compare: TListSortComparer_Context; Context: Pointer; SortingAlgorithm: PSortingAlgorithm);
     property Capacity: Integer read GetCapacity write SetCapacity;
     property Count: Integer read GetCount write SetCount;
     property Items[Index: Integer]: Pointer read Get write Put; default;
Index: rtl/objpas/classes/lists.inc
===================================================================
--- rtl/objpas/classes/lists.inc	(revision 42655)
+++ rtl/objpas/classes/lists.inc	(working copy)
@@ -312,6 +312,18 @@
 end;
 
 
+procedure TFPList.Sort(Compare: TListSortComparer_Context; Context: Pointer);
+begin
+  Sort(Compare, Context, SortBase.DefaultSortingAlgorithm);
+end;
+
+
+procedure TFPList.Sort(Compare: TListSortComparer_Context; Context: Pointer; SortingAlgorithm: PSortingAlgorithm);
+begin
+  SortingAlgorithm^.PtrListSorter_ContextComparer(PPointer(FList), FCount, Compare, Context);
+end;
+
+
 procedure TFPList.ForEachCall(proc2call:TListCallback;arg:pointer);
 var
   i : integer;
@@ -784,6 +796,16 @@
   FList.Sort(Compare, SortingAlgorithm);
 end;
 
+procedure TList.Sort(Compare: TListSortComparer_Context; Context: Pointer);
+begin
+  FList.Sort(Compare, Context);
+end;
+
+procedure TList.Sort(Compare: TListSortComparer_Context; Context: Pointer; SortingAlgorithm: PSortingAlgorithm);
+begin
+  FList.Sort(Compare, Context, SortingAlgorithm);
+end;
+
 procedure TList.CopyMove (aList : TList);
 var r : integer;
 begin

Thaddy de Koning

2019-08-15 08:23

reporter   ~0117679

renders -0 if equal if duplicates allowed? But a nice feature.

Ondrej Pokorny

2019-08-15 11:39

reporter   ~0117684

You may ask your math teacher what -0 is if you think it is relevant for the patch.

Michael Van Canneyt

2019-08-24 12:47

administrator   ~0117823

Checked & Applied, thanks !

Ondrej Pokorny

2019-08-30 09:34

reporter   ~0117873

Thank you!

Issue History

Date Modified Username Field Change
2019-08-14 07:31 Ondrej Pokorny New Issue
2019-08-14 07:31 Ondrej Pokorny File Added: list-sort-context-01.patch
2019-08-14 10:34 Michael Van Canneyt Assigned To => Michael Van Canneyt
2019-08-14 10:34 Michael Van Canneyt Status new => assigned
2019-08-15 08:23 Thaddy de Koning Note Added: 0117679
2019-08-15 11:39 Ondrej Pokorny Note Added: 0117684
2019-08-24 12:47 Michael Van Canneyt Status assigned => resolved
2019-08-24 12:47 Michael Van Canneyt Resolution open => fixed
2019-08-24 12:47 Michael Van Canneyt Fixed in Version => 3.3.1
2019-08-24 12:47 Michael Van Canneyt Fixed in Revision => 42798
2019-08-24 12:47 Michael Van Canneyt FPCTarget => 3.2.0
2019-08-24 12:47 Michael Van Canneyt Note Added: 0117823
2019-08-30 09:34 Ondrej Pokorny Status resolved => closed
2019-08-30 09:34 Ondrej Pokorny Note Added: 0117873