+ generic implementation of list and map; adapt TList/TStringList to use it

git-svn-id: trunk@5624 -

rtl/linux/Makefile.fpc

@@ -16,7 +16,7 @@ units=$(SYSTEMUNIT) $(SYSINIT_UNITS) \
       charset ucomplex getopts \
       errors sockets gpm ipc serial terminfo dl dynlibs \
       video mouse keyboard variants types dateutils sysconst fmtbcd \
-      cthreads classes convutils stdconvs strutils rtlconsts dos objects cwstring fpcylix
+      cthreads classes fgl convutils stdconvs strutils rtlconsts dos objects cwstring fpcylix
 
 rsts=math varutils typinfo variants sysconst rtlconsts stdconvs
 
@@ -44,7 +44,7 @@ libunits=$(SYSTEMUNIT) objpas strings dos \
       sysutils typinfo math \
       $(CPU_UNITS) getopts \
       errors sockets varutils \
-      classes variants sysconst rtlconsts \
+      classes fgl variants sysconst rtlconsts \
 
 [prerules]
 RTL=..
@@ -189,7 +189,7 @@ sysutils$(PPUEXT) : $(UNIXINC)/sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.in
         $(COMPILER) -Fi$(OBJPASDIR)/sysutils $(UNIXINC)/sysutils.pp
 
 classes$(PPUEXT) : $(UNIXINC)/classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
-                   sysutils$(PPUEXT) typinfo$(PPUEXT) rtlconsts$(PPUEXT)
+                   sysutils$(PPUEXT) typinfo$(PPUEXT) rtlconsts$(PPUEXT) fgl$(PPUEXT)
         $(COMPILER) -Fi$(OBJPASDIR)/classes $(UNIXINC)/classes.pp
 
 typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT) sysutils$(PPUEXT) rtlconsts$(PPUEXT)
@@ -211,6 +211,9 @@ variants$(PPUEXT) : $(INC)/variants.pp sysutils$(PPUEXT) sysconst$(PPUEXT) varut
 fmtbcd$(PPUEXT) : $(OBJPASDIR)/fmtbcd.pp objpas$(PPUEXT) sysutils$(PPUEXT) variants$(PPUEXT) classes$(PPUEXT) system$(PPUEXT)
         $(COMPILER) $(OBJPASDIR)/fmtbcd.pp
 
+fgl$(PPUEXT) : $(OBJPASDIR)/fgl.pp objpas$(PPUEXT) types$(PPUEXT) system$(PPUEXT) sysutils$(PPUEXT)
+        $(COMPILER) $(OBJPASDIR)/fgl.pp
+
 types$(PPUEXT) : $(OBJPASDIR)/types.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
         $(COMPILER) $(OBJPASDIR)/types.pp
 

rtl/objpas/fgl.pp

@@ -1,11 +1,10 @@
 {
     This file is part of the Free Pascal run time library.
-    Copyright (c) 2006 by Florian Klaempfl
+    Copyright (c) 2006 by Micha Nelissen
+    member of the Free Pascal development team
 
     It contains the Free Pascal generics library
 
-    member of the Free Pascal development team
-
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
 
@@ -19,393 +18,951 @@
 { be aware, this unit is a prototype and subject to be changed heavily }
 unit fgl;
 
-  interface
-
-   const
-     MaxListSize = Maxint div 16;
-
-   type
-     { TFPList class }
-     generic TGList<TG> = class(TObject)
-     type
-       PTGList = ^TTGList;
-       TTGList = array[0..MaxListSize - 1] of TG;
-       TListSortCompare = function (Item1, Item2: TG): Integer;
-       TListCallback = procedure(data,arg: TG) of object;
-       TListStaticCallback = procedure(data,arg: TG);
-     var
-     private
-       FList: PTGList;
-       FCount: Integer;
-       FCapacity: Integer;
-     protected
-       function Get(Index: Integer): TG; inline;
-       procedure Put(Index: Integer; Item: TG); inline;
-       procedure SetCapacity(NewCapacity: Integer);
-       procedure SetCount(NewCount: Integer);
-       Procedure RaiseIndexError(Index : Integer);
-     public
-       destructor Destroy; override;
-       function Add(const Item: TG): Integer; inline;
-       procedure Clear;
-       procedure Delete(Index: Integer); inline;
-       class procedure Error(const Msg: string; Data: PtrInt);
-       procedure Exchange(Index1, Index2: Integer);
-       function Expand: TGList; inline;
-       function Extract(const item: TG): TG;
-       function First: TG;
-       function IndexOf(const Item: TG): Integer;
-       procedure Insert(Index: Integer; Item: TG); inline;
-       function Last: TG;
-       procedure Move(CurIndex, NewIndex: Integer);
-       procedure Assign(Obj:TGList);
-       function Remove(const Item: TG): Integer;
-       procedure Pack;
-       procedure Sort(Compare: TListSortCompare);
-       procedure ForEachCall(proc2call:TListCallback;arg:pointer);
-       procedure ForEachCall(proc2call:TListStaticCallback;arg:pointer);
-       property Capacity: Integer read FCapacity write SetCapacity;
-       property Count: Integer read FCount write SetCount;
-       property Items[Index: Integer]: TG read Get write Put; default;
-       property List: PTGList read FList;
-     end;
-
-  implementation
-
-    uses
-      rtlconsts,sysutils,classes;
-
-{****************************************************************************}
-{*                           TGList                                        *}
-{****************************************************************************}
-
-    procedure TGList.RaiseIndexError(Index : Integer);
-      begin
-        Error(SListIndexError, Index);
-      end;
-
-
-    function TGList.Get(Index: Integer): Pointer; inline;
-      begin
-        If (Index < 0) or (Index >= FCount) then
-          RaiseIndexError(Index);
-        Result:=FList^[Index];
-      end;
-
-
-    procedure TGList.Put(Index: Integer; Item: Pointer); inline;
-      begin
-        if (Index < 0) or (Index >= FCount) then
-          RaiseIndexError(Index);
-        Flist^[Index] := Item;
-      end;
-
-
-    function TGList.Extract(const item: TG): TG;
-      var
-        i : Integer;
-      begin
-        result := nil;
-        i := IndexOf(item);
-        if i >= 0 then
-         begin
-           Result := item;
-           FList^[i] := nil;
-           Delete(i);
-         end;
-      end;
-
-
-    procedure TGList.SetCapacity(NewCapacity: Integer);
-      begin
-        If (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
-           Error (SListCapacityError, NewCapacity);
-        if NewCapacity = FCapacity then
-          exit;
-        ReallocMem(FList, SizeOf(Pointer)*NewCapacity);
-        FCapacity := NewCapacity;
-      end;
-
-
-    procedure TGList.SetCount(NewCount: Integer);
-      Const
-        // Ratio of Pointer and Word Size.
-        WordRatio = SizeOf(TG) Div SizeOf(Word);
-
-      begin
-        if (NewCount < 0) or (NewCount > MaxListSize)then
-          Error(SListCountError, NewCount);
-        If NewCount > FCount then
-          begin
-          If NewCount > FCapacity then
-            SetCapacity(NewCount);
-          If FCount < NewCount then
-            FillWord(Flist^[FCount], (NewCount-FCount) *  WordRatio, 0);
-          end;
-        FCount := Newcount;
-      end;
-
-
-    destructor TGList.Destroy;
-      begin
-        Self.Clear;
-        inherited Destroy;
-      end;
-
-
-    function TGList.Add(const Item: TG): Integer; inline;
-      begin
-        if FCount = FCapacity then
-          Self.Expand;
-        FList^[FCount] := Item;
-        Result := FCount;
-        FCount := FCount + 1;
-      end;
-
-
-    procedure TGList.Clear;
-      begin
-        if Assigned(FList) then
-        begin
-          SetCount(0);
-          SetCapacity(0);
-          FList := nil;
-        end;
-      end;
-
-
-    procedure TGList.Delete(Index: Integer); inline;
-      begin
-        If (Index<0) or (Index>=FCount) then
-          Error (SListIndexError, Index);
-        FCount := FCount-1;
-        System.Move (FList^[Index+1], FList^[Index], (FCount - Index) * SizeOf(Pointer));
-        // Shrink the list if appropriate
-        if (FCapacity > 256) and (FCount < FCapacity shr 2) then
+interface
+
+uses
+  types, sysutils;
+
+const
+  MaxListSize = Maxint div 16;
+
+type
+  EListError = class(Exception);
+
+  TFPSList = class;
+  TFPSListCompareFunc = function(Key1, Key2: Pointer): Integer of object;
+
+  TFPSList = class(TObject)
+  protected
+    FList: PByte;
+    FCount: Integer;
+    FCapacity: Integer; { list is one longer than capacity, for temp }
+    FItemSize: Integer;
+    procedure CopyItem(Src, Dest: Pointer); virtual;
+    procedure Deref(Item: Pointer); virtual; overload;
+    procedure Deref(FromIndex, ToIndex: Integer); overload;
+    function Get(Index: Integer): Pointer;
+    procedure InternalExchange(Index1, Index2: Integer);
+    function  InternalGet(Index: Integer): Pointer; {$ifdef CLASSESINLINE} inline; {$endif}
+    procedure InternalPut(Index: Integer; NewItem: Pointer);
+    procedure Put(Index: Integer; Item: Pointer);
+    procedure QuickSort(L, R: Integer; Compare: TFPSListCompareFunc);
+    procedure SetCapacity(NewCapacity: Integer);
+    procedure SetCount(NewCount: Integer);
+    procedure RaiseIndexError(Index : Integer);
+    property InternalItems[Index: Integer]: Pointer read InternalGet write InternalPut;
+  public
+    constructor Create(AItemSize: Integer = sizeof(Pointer));
+    destructor Destroy; override;
+    function Add(Item: Pointer): Integer;
+    procedure Clear;
+    procedure Delete(Index: Integer);
+    class procedure Error(const Msg: string; Data: PtrInt);
+    procedure Exchange(Index1, Index2: Integer);
+    function Expand: TFPSList;
+    function Extract(Item: Pointer): Pointer;
+    function First: Pointer;
+    function IndexOf(Item: Pointer): Integer;
+    procedure Insert(Index: Integer; Item: Pointer);
+    function Insert(Index: Integer): Pointer;
+    function Last: Pointer;
+    procedure Move(CurIndex, NewIndex: Integer);
+    procedure Assign(Obj: TFPSList);
+    function Remove(Item: Pointer): Integer;
+    procedure Pack;
+    procedure Sort(Compare: TFPSListCompareFunc);
+    procedure ForEachCall(Proc2call: TListCallback; Arg: Pointer);
+    procedure ForEachCall(Proc2call: TListStaticCallback; Arg: Pointer);
+    property Capacity: Integer read FCapacity write SetCapacity;
+    property Count: Integer read FCount write SetCount;
+    property Items[Index: Integer]: Pointer read Get write Put; default;
+    property ItemSize: Integer read FItemSize;
+    property List: PByte read FList;
+  end;
+
+{$ifndef VER2_0}
+
+  generic TFPGList<T> = class(TFPSList)
+  type public
+    TCompareFunc = function(const Item1, Item2: T): Integer;
+  var protected
+    FOnCompare: TCompareFunc;
+    procedure CopyItem(Src, Dest: Pointer); override;
+    procedure Deref(Item: Pointer); override;
+    function  Get(Index: Integer): T; {$ifdef CLASSESINLINE} inline; {$endif}
+    function  ItemPtrCompare(Item1, Item2: Pointer): Integer;
+    procedure Put(Index: Integer; const Item: T); {$ifdef CLASSESINLINE} inline; {$endif}
+  public
+    constructor Create;
+    function Extract(const Item: T): T; {$ifdef CLASSESINLINE} inline; {$endif}
+    function First: T; {$ifdef CLASSESINLINE} inline; {$endif}
+    function IndexOf(const Item: T): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
+    procedure Insert(Index: Integer; const Item: T); {$ifdef CLASSESINLINE} inline; {$endif}
+    function Last: T; {$ifdef CLASSESINLINE} inline; {$endif}
+    {$warning TODO: fix TFPGList<T>.Assign(TFPGList) to work somehow}
+    {procedure Assign(Source: TFPGList);}
+    function Remove(const Item: T): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
+    procedure Sort(Compare: TCompareFunc);
+    property Items[Index: Integer]: T read Get write Put; default;
+  end;
+
+{$endif}
+
+  TFPSMap = class(TFPSList)
+  private
+    FKeySize: Integer;
+    FDataSize: Integer;
+    FDuplicates: TDuplicates;
+    FSorted: Boolean;
+    FOnPtrCompare: TFPSListCompareFunc;
+    procedure SetSorted(Value: Boolean);
+  protected
+    function BinaryCompare(Key1, Key2: Pointer): Integer;
+    procedure CopyKey(Src, Dest: Pointer); virtual;
+    procedure CopyData(Src, Dest: Pointer); virtual;
+    function GetKey(Index: Integer): Pointer;
+    function GetKeyData(AKey: Pointer): Pointer;
+    function GetData(Index: Integer): Pointer;
+    procedure InitOnPtrCompare;
+    function LinearIndexOf(AKey: Pointer): Integer;
+    procedure PutKey(Index: Integer; AKey: Pointer);
+    procedure PutKeyData(AKey: Pointer; NewData: Pointer);
+    procedure PutData(Index: Integer; AData: Pointer);
+  public
+    constructor Create(AKeySize: Integer = sizeof(Pointer); 
+      ADataSize: integer = sizeof(Pointer));
+    function Add(AKey, AData: Pointer): Integer;
+    function Add(AKey: Pointer): Integer;
+    function Find(AKey: Pointer; var Index: Integer): Boolean;
+    function IndexOf(AKey: Pointer): Integer;
+    function IndexOfData(AData: Pointer): Integer;
+    function Insert(Index: Integer): Pointer;
+    procedure Insert(Index: Integer; var AKey, AData: Pointer);
+    procedure InsertKey(Index: Integer; AKey: Pointer);
+    procedure InsertKeyData(Index: Integer; AKey, AData: Pointer);
+    function Remove(AKey: Pointer): Integer;
+    procedure Sort;
+    property Duplicates: TDuplicates read FDuplicates write FDuplicates;
+    property KeySize: Integer read FKeySize;
+    property DataSize: Integer read FDataSize;
+    property Keys[Index: Integer]: Pointer read GetKey write PutKey;
+    property Data[Index: Integer]: Pointer read GetData write PutData;
+    property KeyData[Key: Pointer]: Pointer read GetKeyData write PutKeyData; default;
+    property Sorted: Boolean read FSorted write SetSorted;
+    property OnPtrCompare: TFPSListCompareFunc read FOnPtrCompare write FOnPtrCompare;
+  end;
+
+{$ifndef VER2_0}
+
+  generic TFPGMap<TKey, TData> = class(TFPSMap)
+  type public
+    TCompareFunc = function(const Key1, Key2: TKey): Integer;
+  var protected
+    FOnCompare: TCompareFunc;
+    procedure CopyItem(Src, Dest: Pointer); override;
+    procedure CopyKey(Src, Dest: Pointer); override;
+    procedure CopyData(Src, Dest: Pointer); override;
+    procedure Deref(Item: Pointer); override;
+    function GetKey(Index: Integer): TKey; {$ifdef CLASSESINLINE} inline; {$endif}
+    function GetKeyData(const AKey: TKey): TData; {$ifdef CLASSESINLINE} inline; {$endif}
+    function GetData(Index: Integer): TData; {$ifdef CLASSESINLINE} inline; {$endif}
+    function KeyPtrCompare(Key1, Key2: Pointer): Integer;
+    procedure PutKey(Index: Integer; const NewKey: TKey); {$ifdef CLASSESINLINE} inline; {$endif}
+    procedure PutKeyData(const AKey: TKey; const NewData: TData); {$ifdef CLASSESINLINE} inline; {$endif}
+    procedure PutData(Index: Integer; const NewData: TData); {$ifdef CLASSESINLINE} inline; {$endif}
+    procedure SetOnCompare(NewCompare: TCompareFunc);
+  public
+    constructor Create;
+    function Add(const AKey: TKey; const AData: TData): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
+    function Add(const AKey: TKey): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
+    function Find(const AKey: TKey; var Index: Integer): Boolean; {$ifdef CLASSESINLINE} inline; {$endif}
+    function IndexOf(const AKey: TKey): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
+    function IndexOfData(const AData: TData): Integer;
+    procedure InsertKey(Index: Integer; const AKey: TKey);
+    procedure InsertKeyData(Index: Integer; const AKey: TKey; const AData: TData);
+    function Remove(const AKey: TKey): Integer;
+    property Keys[Index: Integer]: TKey read GetKey write PutKey;
+    property Data[Index: Integer]: TData read GetData write PutData;
+    property KeyData[const AKey: TKey]: TData read GetKeyData write PutKeyData; default;
+    property OnCompare: TCompareFunc read FOnCompare write SetOnCompare;
+  end;
+
+{$endif}
+
+implementation
+
+uses
+  rtlconsts;
+
+{****************************************************************************
+                             TFPSList
+ ****************************************************************************}
+
+constructor TFPSList.Create(AItemSize: integer);
+begin
+  inherited Create;
+  FItemSize := AItemSize;
+end;
+
+destructor TFPSList.Destroy;
+begin
+  Clear;
+  inherited Destroy;
+end;
+
+procedure TFPSList.CopyItem(Src, Dest: Pointer);
+begin
+  System.Move(Src^, Dest^, FItemSize);
+end;
+
+procedure TFPSList.RaiseIndexError(Index : Integer);
+begin
+  Error(SListIndexError, Index);
+end;
+
+function TFPSList.InternalGet(Index: Integer): Pointer;
+begin
+  Result:=FList+Index*ItemSize;
+end;
+
+procedure TFPSList.InternalPut(Index: Integer; NewItem: Pointer);
+var
+  ListItem: Pointer;
+begin
+  ListItem := InternalItems[Index];
+  CopyItem(NewItem, ListItem);
+end;
+
+function TFPSList.Get(Index: Integer): Pointer;
+begin
+  if (Index < 0) or (Index >= FCount) then
+    RaiseIndexError(Index);
+  Result := InternalItems[Index];
+end;
+
+procedure TFPSList.Put(Index: Integer; Item: Pointer);
+begin
+  if (Index < 0) or (Index >= FCount) then
+    RaiseIndexError(Index);
+  InternalItems[Index] := Item;
+end;
+
+procedure TFPSList.SetCapacity(NewCapacity: Integer);
+begin
+  If (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
+     Error (SListCapacityError, NewCapacity);
+  if NewCapacity = FCapacity then
+    exit;
+  ReallocMem(FList, (NewCapacity+1) * FItemSize);
+  FCapacity := NewCapacity;
+end;
+
+procedure TFPSList.Deref(Item: Pointer);
+begin
+end;
+
+procedure TFPSList.Deref(FromIndex, ToIndex: Integer);
+var
+  ListItem, ListItemLast: Pointer;
+begin
+  ListItem := InternalItems[FromIndex];
+  ListItemLast := InternalItems[ToIndex];
+  repeat
+    Deref(ListItem);
+    if ListItem = ListItemLast then
+      break;
+    ListItem := PByte(ListItem) + ItemSize;
+  until false;
+end;
+
+procedure TFPSList.SetCount(NewCount: Integer);
+begin
+  if (NewCount < 0) or (NewCount > MaxListSize) then
+    Error(SListCountError, NewCount);
+  if NewCount > FCount then
+  begin
+    if NewCount > FCapacity then
+      SetCapacity(NewCount);
+    if NewCount > FCount then
+      FillByte(InternalItems[FCount]^, (NewCount-FCount) * FItemSize, 0)
+    else if NewCount < FCount then 
+      Deref(NewCount, FCount-1);
+  end;
+  FCount := NewCount;
+end;
+
+function TFPSList.Add(Item: Pointer): Integer;
+begin
+  if FCount = FCapacity then
+    Self.Expand;
+  CopyItem(Item, InternalItems[FCount]);
+  Result := FCount;
+  Inc(FCount);
+end;
+
+procedure TFPSList.Clear;
+begin
+  if Assigned(FList) then
+  begin
+    SetCount(0);
+    SetCapacity(0);
+    FList := nil;
+  end;
+end;
+
+procedure TFPSList.Delete(Index: Integer);
+var
+  ListItem: Pointer;
+begin
+  if (Index < 0) or (Index >= FCount) then
+    Error(SListIndexError, Index);
+  Dec(FCount);
+  ListItem := InternalItems[Index];
+  Deref(ListItem);
+  System.Move(InternalItems[Index+1]^, ListItem^, (FCount - Index) * FItemSize);
+  // Shrink the list if appropriate
+  if (FCapacity > 256) and (FCount < FCapacity shr 2) then
+  begin
+    FCapacity := FCapacity shr 1;
+    ReallocMem(FList, (FCapacity+1) * FItemSize);
+  end;
+end;
+
+function TFPSList.Extract(Item: Pointer): Pointer;
+var
+  i : Integer;
+begin
+  Result := nil;
+  i := IndexOf(Item);
+  if i >= 0 then
+  begin
+    Result := InternalItems[i];
+    System.Move(Result^, InternalItems[FCapacity]^, FItemSize);
+    Delete(i);
+  end;
+end;
+
+class procedure TFPSList.Error(const Msg: string; Data: PtrInt);
+begin
+  raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
+end;
+
+procedure TFPSList.Exchange(Index1, Index2: Integer);
+begin
+  if ((Index1 >= FCount) or (Index1 < 0)) then
+    Error(SListIndexError, Index1);
+  if ((Index2 >= FCount) or (Index2 < 0)) then
+    Error(SListIndexError, Index2);
+  InternalExchange(Index1, Index2);
+end;
+
+procedure TFPSList.InternalExchange(Index1, Index2: Integer);
+begin
+  System.Move(InternalItems[Index1]^, InternalItems[FCapacity]^, FItemSize);
+  System.Move(InternalItems[Index2]^, InternalItems[Index1]^, FItemSize);
+  System.Move(InternalItems[FCapacity]^, InternalItems[Index2]^, FItemSize);
+end;
+
+function TFPSList.Expand: TFPSList;
+var
+  IncSize : Longint;
+begin
+  if FCount < FCapacity then exit;
+  IncSize := 4;
+  if FCapacity > 3 then IncSize := IncSize + 4;
+  if FCapacity > 8 then IncSize := IncSize + 8;
+  if FCapacity > 127 then Inc(IncSize, FCapacity shr 2);
+  SetCapacity(FCapacity + IncSize);
+  Result := Self;
+end;
+
+function TFPSList.First: Pointer;
+begin
+  If FCount = 0 then
+    Result := Nil
+  else
+    Result := InternalItems[0];
+end;
+
+function TFPSList.IndexOf(Item: Pointer): Integer;
+var
+  ListItem: Pointer;
+begin
+  Result := 0;
+  ListItem := First;
+  while (Result < FCount) and (CompareByte(ListItem^, Item^, FItemSize) <> 0) do
+  begin
+    Inc(Result);
+    ListItem := PByte(ListItem)+FItemSize;
+  end;
+  if Result = FCount then Result := -1;
+end;
+
+function TFPSList.Insert(Index: Integer): Pointer;
+begin
+  if (Index < 0) or (Index > FCount) then
+    Error(SListIndexError, Index);
+  if FCount = FCapacity then Self.Expand;
+  if Index<FCount then
+    System.Move(InternalItems[Index]^, InternalItems[Index+1]^, (FCount - Index) * FItemSize);
+  Result := InternalItems[Index];
+  Inc(FCount);
+end;
+
+procedure TFPSList.Insert(Index: Integer; Item: Pointer);
+begin
+  CopyItem(Item, Insert(Index));
+end;
+
+function TFPSList.Last: Pointer;
+begin
+  if FCount = 0 then
+    Result := nil
+  else
+    Result := InternalItems[FCount - 1];
+end;
+
+procedure TFPSList.Move(CurIndex, NewIndex: Integer);
+var
+  CurItem, NewItem, TmpItem, Src, Dest: Pointer;
+  MoveCount: Integer;
+begin
+  if (CurIndex < 0) or (CurIndex >= Count) then
+    Error(SListIndexError, CurIndex);
+  if (NewIndex < 0) or (NewIndex >= Count) then
+    Error(SListIndexError, NewIndex);
+  if CurIndex = NewIndex then
+    exit;
+  CurItem := InternalItems[CurIndex];
+  NewItem := InternalItems[NewIndex];
+  TmpItem := InternalItems[FCapacity];
+  System.Move(CurItem^, TmpItem^, FItemSize);
+  if NewIndex > CurIndex then
+  begin
+    Src := InternalItems[CurIndex+1];
+    Dest := CurItem;
+    MoveCount := NewIndex - CurIndex;
+  end else begin
+    Src := NewItem;
+    Dest := InternalItems[NewIndex+1];
+    MoveCount := CurIndex - NewIndex;
+  end;
+  System.Move(Src^, Dest^, MoveCount * FItemSize);
+  System.Move(TmpItem^, NewItem^, FItemSize);
+end;
+
+function TFPSList.Remove(Item: Pointer): Integer;
+begin
+  Result := IndexOf(Item);
+  if Result <> -1 then
+    Delete(Result);
+end;
+
+procedure TFPSList.Pack;
+var
+  NewCount,
+  i : integer;
+  pdest,
+  psrc : Pointer;
+begin
+  NewCount:=0;
+  psrc:=First;
+  pdest:=psrc;
+  For I:=0 To FCount-1 Do
+    begin
+      if assigned(pointer(psrc^)) then
         begin
-          FCapacity := FCapacity shr 1;
-          ReallocMem(FList, SizeOf(Pointer) * FCapacity);
+          System.Move(psrc^, pdest^, FItemSize);
+          inc(pdest);
+          inc(NewCount);
         end;
-      end;
-
-
-    class procedure TGList.Error(const Msg: string; Data: PtrInt);
-      begin
-        Raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
-      end;
-
-
-    procedure TGList.Exchange(Index1, Index2: Integer);
-      var
-        Temp : Pointer;
-      begin
-        If ((Index1 >= FCount) or (Index1 < 0)) then
-          Error(SListIndexError, Index1);
-        If ((Index2 >= FCount) or (Index2 < 0)) then
-          Error(SListIndexError, Index2);
-        Temp := FList^[Index1];
-        FList^[Index1] := FList^[Index2];
-        FList^[Index2] := Temp;
-      end;
-
-
-    function TGList.Expand: TGList; inline;
-      var
-        IncSize : Longint;
-      begin
-        if FCount < FCapacity then exit;
-        IncSize := 4;
-        if FCapacity > 3 then IncSize := IncSize + 4;
-        if FCapacity > 8 then IncSize := IncSize+8;
-        if FCapacity > 127 then Inc(IncSize, FCapacity shr 2);
-        SetCapacity(FCapacity + IncSize);
-        Result := Self;
-      end;
-
-
-    function TGList.First: Pointer;
-      begin
-        If FCount = 0 then
-          Result := Nil
-        else
-          Result := Items[0];
-      end;
-
-
-    function TGList.IndexOf(const Item: TG): Integer;
+      inc(psrc);
+    end;
+  FCount:=NewCount;
+end;
+
+// Needed by Sort method.
+
+procedure TFPSList.QuickSort(L, R: Integer; Compare: TFPSListCompareFunc);
+var
+  I, J, P: Integer;
+  PivotItem: Pointer;
+begin
+  repeat
+    I := L;
+    J := R;
+    P := (L + R) div 2;
+    repeat
+      PivotItem := InternalItems[P];
+      while Compare(PivotItem, InternalItems[I]) > 0 do
+        Inc(I);
+      while Compare(PivotItem, InternalItems[J]) < 0 do
+        Dec(J);
+      if I <= J then
       begin
-        Result := 0;
-        while(Result < FCount) and (Flist^[Result] <> Item) do Result := Result + 1;
-        If Result = FCount  then Result := -1;
+        InternalExchange(I, J);
+        if P = I then
+          P := J
+        else if P = J then
+          P := I;
+        Inc(I);
+        Dec(J);
       end;
+    until I > J;
+    if L < J then
+      QuickSort(L, J, Compare);
+    L := I;
+  until I >= R;
+end;
+
+procedure TFPSList.Sort(Compare: TFPSListCompareFunc);
+begin
+  if not Assigned(FList) or (FCount < 2) then exit;
+  QuickSort(0, FCount-1, Compare);
+end;
+
+procedure TFPSList.Assign(Obj: TFPSList);
+var
+  i: Integer;
+begin
+  if Obj.ItemSize <> FItemSize then
+    Error(SListItemSizeError, 0);
+  Clear;
+  for I := 0 to Obj.Count - 1 do
+    Add(Obj[i]);
+end;
+
+procedure TFPSList.ForEachCall(Proc2call: TListCallback; Arg: Pointer);
+var
+  I: integer;
+begin
+  for I:=0 to Count-1 do
+    proc2call(InternalItems[I],arg);
+end;
+
+
+procedure TFPSList.ForEachCall(Proc2call: TListStaticCallback; Arg: Pointer);
+var
+  I: integer;
+begin
+  for I:=0 to Count-1 do
+    Proc2call(InternalItems[I], Arg);
+end;
 
+{****************************************************************************}
+{*                TFPGList                                                  *}
+{****************************************************************************}
 
-    procedure TGList.Insert(Index: Integer; Item: Pointer); inline;
-      begin
-        if (Index < 0) or (Index > FCount )then
-          Error(SlistIndexError, Index);
-        iF FCount = FCapacity then Self.Expand;
-        if Index<FCount then
-          System.Move(Flist^[Index], Flist^[Index+1], (FCount - Index) * SizeOf(Pointer));
-        FList^[Index] := Item;
-        FCount := FCount + 1;
-      end;
-
-
-    function TGList.Last: Pointer;
-      begin
-      { Wouldn't it be better to return nil if the count is zero ?}
-        If FCount = 0 then
-          Result := nil
-        else
-          Result := Items[FCount - 1];
-      end;
-
-
-    procedure TGList.Move(CurIndex, NewIndex: Integer);
-      var
-        Temp : Pointer;
-      begin
-        if ((CurIndex < 0) or (CurIndex > Count - 1)) then
-          Error(SListIndexError, CurIndex);
-        if (NewINdex < 0) then
-          Error(SlistIndexError, NewIndex);
-        Temp := FList^[CurIndex];
-        FList^[CurIndex] := nil;
-        Self.Delete(CurIndex);
-        Self.Insert(NewIndex, nil);
-        FList^[NewIndex] := Temp;
-      end;
-
-
-    function TGList.Remove(const Item: TG): Integer;
-      begin
-        Result := IndexOf(Item);
-        If Result <> -1 then
-          Self.Delete(Result);
-      end;
-
-
-    procedure TGList.Pack;
-      Var
-        {Last,I,J,}
-        Runner : Longint;
-      begin
-        // Not the fastest; but surely correct
-        {
-        for Runner := Fcount - 1 downto 0 do
-          if Items[Runner] = Nil then
-            Self.Delete(Runner);
-        }
-      { The following may be faster in case of large and defragmented lists
-        If count=0 then exit;
-        Runner:=0;I:=0;
-        TheLast:=Count;
-        while runner<count do
-          begin
-          // Find first Nil
-          While (FList^[Runner]<>Nil) and (Runner<Count) do Runner:=Runner+1;
-          if Runner<Count do
-            begin
-            // Start searching for non-nil from last known nil+1
-            if i<Runner then I:=Runner+1;
-            While (Flist[I]^=Nil) and (I<Count) do I:=I+1;
-            // Start looking for last non-nil of block.
-            J:=I+1;
-            While (Flist^[J]<>Nil) and (J<Count) do J:=J+1;
-            // Move block and zero out
-            Move (Flist^[I],Flist^[Runner],J*SizeOf(Pointer));
-            FillWord (Flist^[I],(J-I)*WordRatio,0);
-            // Update Runner and Last to point behind last block
-            TheLast:=Runner+(J-I);
-            If J=Count then
-               begin
-               // Shortcut, when J=Count we checked all pointers
-               Runner:=Count
-            else
-               begin
-               Runner:=TheLast;
-               I:=j;
-            end;
-          end;
-        Count:=TheLast;
-      }
-      end;
-
-    // Needed by Sort method.
-
-    Procedure QuickSort(FList: PPointerList; L, R : Longint;
-                         Compare: TListSortCompare);
-      var
-        I, J : Longint;
-        P, Q : Pointer;
-      begin
-       repeat
-         I := L;
-         J := R;
-         P := FList^[ (L + R) div 2 ];
-         repeat
-           while Compare(P, FList^[i]) > 0 do
-             I := I + 1;
-           while Compare(P, FList^[J]) < 0 do
-             J := J - 1;
-           If I <= J then
-           begin
-             Q := FList^[I];
-             Flist^[I] := FList^[J];
-             FList^[J] := Q;
-             I := I + 1;
-             J := J - 1;
-           end;
-         until I > J;
-         if L < J then
-           QuickSort(FList, L, J, Compare);
-         L := I;
-       until I >= R;
-      end;
-
-    procedure TGList.Sort(Compare: TListSortCompare);
-      begin
-        if Not Assigned(FList) or (FCount < 2) then exit;
-        QuickSort(Flist, 0, FCount-1, Compare);
-      end;
-
-
-    procedure TGList.Assign(Obj: TGList);
-      var
-        i: Integer;
-      begin
-        Clear;
-        for I := 0 to Obj.Count - 1 do
-          Add(Obj[i]);
-      end;
-
-
-    procedure TGList.ForEachCall(proc2call:TListCallback;arg:pointer);
-      var
-        i : integer;
-        p : pointer;
-      begin
-        For I:=0 To Count-1 Do
-          begin
-            p:=FList^[i];
-            if assigned(p) then
-              proc2call(p,arg);
-          end;
+{$ifndef VER2_0}
+
+constructor TFPGList.Create;
+begin
+  inherited Create(sizeof(T));
+end;
+
+procedure TFPGList.CopyItem(Src, Dest: Pointer);
+begin
+  T(Dest^) := T(Src^);
+end;
+
+procedure TFPGList.Deref(Item: Pointer);
+begin
+  Finalize(T(Item^));
+end;
+
+function TFPGList.Get(Index: Integer): T;
+begin
+  Result := T(inherited Get(Index)^);
+end;
+
+function TFPGList.ItemPtrCompare(Item1, Item2: Pointer): Integer;
+begin
+  Result := FOnCompare(T(Item1^), T(Item2^));
+end;
+
+procedure TFPGList.Put(Index: Integer; const Item: T);
+begin
+  inherited Put(Index, @Item);
+end;
+
+function TFPGList.Extract(const Item: T): T;
+var
+  ResPtr: Pointer;
+begin
+  ResPtr := inherited Extract(@Item);
+  if ResPtr <> nil then
+    Result := T(ResPtr^)
+  else
+    FillByte(Result, 0, sizeof(T));
+end;
+
+function TFPGList.First: T;
+begin
+  Result := T(inherited First^);
+end;
+
+function TFPGList.IndexOf(const Item: T): Integer;
+begin
+  Result := 0;
+  while (Result < FCount) and (Items[Result] <> Item) do
+    Inc(Result);
+  {$warning TODO: Result := -1; does not compile }
+  if Result = FCount then 
+  begin
+    Result := 0;
+    dec(Result);
+  end;
+end;
+
+procedure TFPGList.Insert(Index: Integer; const Item: T);
+begin
+  T(inherited Insert(Index)^) := Item;
+end;
+
+function TFPGList.Last: T;
+begin
+  Result := T(inherited Last^);
+end;
+
+function TFPGList.Remove(const Item: T): Integer;
+begin
+  Result := inherited Remove(@Item);
+end;
+
+procedure TFPGList.Sort(Compare: TCompareFunc);
+begin
+  FOnCompare := Compare;
+  inherited Sort(@ItemPtrCompare);
+end;
+
+{$endif}
+
+{****************************************************************************
+                             TFPSMap
+ ****************************************************************************}
+
+constructor TFPSMap.Create(AKeySize: Integer; ADataSize: integer);
+begin
+  inherited Create(AKeySize+ADataSize);
+  FKeySize := AKeySize;
+  FDataSize := ADataSize;
+  InitOnPtrCompare;
+end;
+
+procedure TFPSMap.CopyKey(Src, Dest: Pointer);
+begin
+  System.Move(Src^, Dest^, FKeySize);
+end;
+
+procedure TFPSMap.CopyData(Src, Dest: Pointer);
+begin
+  System.Move(Src^, Dest^, FDataSize);
+end;
+
+function TFPSMap.BinaryCompare(Key1, Key2: Pointer): Integer;
+begin
+  Result := CompareByte(Key1^, Key2^, FKeySize);
+end;
+
+function TFPSMap.GetKey(Index: Integer): Pointer;
+begin
+  Result := Items[Index];
+end;
+
+function TFPSMap.GetData(Index: Integer): Pointer;
+begin
+  Result := PByte(Items[Index])+FKeySize;
+end;
+
+function TFPSMap.GetKeyData(AKey: Pointer): Pointer;
+var
+  I: Integer;
+begin
+  if Find(AKey, I) then
+    Result := InternalItems[I]
+  else
+    Result := nil;
+end;
+
+procedure TFPSMap.InitOnPtrCompare;
+begin
+  FOnPtrCompare := @BinaryCompare;
+end;
+
+procedure TFPSMap.PutKey(Index: Integer; AKey: Pointer);
+begin
+  if FSorted then
+    Error(SSortedListError, 0);
+  CopyKey(AKey, Items[Index]);
+end;
+
+procedure TFPSMap.PutData(Index: Integer; AData: Pointer);
+begin
+  CopyData(AData, PByte(Items[Index])+FKeySize);
+end;
+
+procedure TFPSMap.PutKeyData(AKey: Pointer; NewData: Pointer);
+var
+  I: Integer;
+begin
+  if Find(AKey, I) then
+    Data[I] := NewData
+  else
+    Add(AKey, NewData);
+end;
+
+procedure TFPSMap.SetSorted(Value: Boolean);
+begin
+  if Value = FSorted then exit;
+  FSorted := Value;
+  if Value then Sort;
+end;
+
+function TFPSMap.Add(AKey: Pointer): Integer;
+begin
+  if Sorted then
+  begin
+    if Find(AKey, Result) then
+      case Duplicates of
+        dupIgnore: exit;
+        dupError: Error(SDuplicateItem, 0)
       end;
-
-
-    procedure TGList.ForEachCall(proc2call:TListStaticCallback;arg:pointer);
-      var
-        i : integer;
-        p : pointer;
+  end else
+    Result := Count;
+  CopyKey(AKey, Insert(Result));
+end;
+
+function TFPSMap.Add(AKey, AData: Pointer): Integer;
+begin
+  Result := Add(AKey);
+  Data[Result] := AData;
+end;
+
+function TFPSMap.Find(AKey: Pointer; var Index: Integer): Boolean;
+{ Searches for the first item <= Key, returns True if exact match,
+  sets index to the index f the found string. }
+var 
+  I,L,R,Dir: Integer;
+begin
+  Result := false;
+  // Use binary search.
+  L := 0;
+  R := FCount-1;
+  while L<=R do
+  begin
+    I := (L+R) div 2;
+    Dir := FOnPtrCompare(Items[I], AKey);
+    if Dir < 0 then
+      L := I+1
+    else begin
+      R := I-1;
+      if Dir = 0 then
       begin
-        For I:=0 To Count-1 Do
-          begin
-            p:=FList^[i];
-            if assigned(p) then
-              proc2call(p,arg);
-          end;
+        Result := true;
+        if Duplicates <> dupAccept then 
+          L := I;
       end;
+    end;
+  end;
+  Index := L;
+end;
+
+function TFPSMap.LinearIndexOf(AKey: Pointer): Integer;
+var
+  ListItem: Pointer;
+begin
+  Result := 0;
+  ListItem := First;
+  while (Result < FCount) and (FOnPtrCompare(ListItem, AKey) <> 0) do
+  begin
+    Inc(Result);
+    ListItem := PByte(ListItem)+FItemSize;
+  end;
+  if Result = FCount then Result := -1;
+end;
+
+function TFPSMap.IndexOf(AKey: Pointer): Integer;
+begin
+  if Sorted then
+  begin
+    if not Find(AKey, Result) then
+      Result := -1;
+  end else
+    Result := LinearIndexOf(AKey);
+end;
+
+function TFPSMap.IndexOfData(AData: Pointer): Integer;
+var
+  ListItem: Pointer;
+begin
+  Result := 0;
+  ListItem := First+FKeySize;
+  while (Result < FCount) and (CompareByte(ListItem^, AData^, FDataSize) <> 0) do
+  begin
+    Inc(Result);
+    ListItem := PByte(ListItem)+FItemSize;
+  end;
+  if Result = FCount then Result := -1;
+end;
+
+function TFPSMap.Insert(Index: Integer): Pointer;
+begin
+  if FSorted then
+    Error(SSortedListError, 0);
+  Result := inherited Insert(Index);
+end;
+
+procedure TFPSMap.Insert(Index: Integer; var AKey, AData: Pointer);
+begin
+  AKey := Insert(Index);
+  AData := PByte(AKey) + FKeySize;
+end;
+
+procedure TFPSMap.InsertKey(Index: Integer; AKey: Pointer);
+begin
+  CopyKey(AKey, Insert(Index));
+end;
+
+procedure TFPSMap.InsertKeyData(Index: Integer; AKey, AData: Pointer);
+var
+  ListItem: Pointer;
+begin
+  ListItem := Insert(Index);
+  CopyKey(AKey, ListItem);
+  CopyData(AData, PByte(ListItem)+FKeySize);
+end;
+
+function TFPSMap.Remove(AKey: Pointer): Integer;
+begin
+  if Find(AKey, Result) then
+    Delete(Result)
+  else
+    Result := -1;
+end;
+
+procedure TFPSMap.Sort;
+begin
+  inherited Sort(FOnPtrCompare);
+end;
+
+{****************************************************************************
+                             TFPGMap
+ ****************************************************************************}
+
+{$ifndef VER2_0}
+
+constructor TFPGMap.Create;
+begin
+  inherited Create(SizeOf(TKey), SizeOf(TData));
+end;
+
+procedure TFPGMap.CopyItem(Src, Dest: Pointer);
+begin
+  CopyKey(Src, Dest);
+  CopyData(PByte(Src)+KeySize, PByte(Dest)+KeySize);
+end;
+
+procedure TFPGMap.CopyKey(Src, Dest: Pointer);
+begin
+  TKey(Dest^) := TKey(Src^);
+end;
+
+procedure TFPGMap.CopyData(Src, Dest: Pointer);
+begin
+  TData(Dest^) := TData(Src^);
+end;
+
+procedure TFPGMap.Deref(Item: Pointer);
+begin
+  Finalize(TKey(Item^));
+  Finalize(TData(Pointer(PByte(Item)+KeySize)^));
+end;
+
+function TFPGMap.GetKey(Index: Integer): TKey;
+begin
+  Result := TKey(inherited GetKey(Index)^);
+end;
+
+function TFPGMap.GetData(Index: Integer): TData;
+begin
+  Result := TData(inherited GetData(Index)^);
+end;
+
+function TFPGMap.GetKeyData(const AKey: TKey): TData;
+begin
+  Result := TData(inherited GetKeyData(@AKey)^);
+end;
+
+function TFPGMap.KeyPtrCompare(Key1, Key2: Pointer): Integer;
+begin
+  Result := FOnCompare(TKey(Key1^), TKey(Key2^));
+end;
+
+procedure TFPGMap.PutKey(Index: Integer; const NewKey: TKey);
+begin
+  inherited PutKey(Index, @NewKey);
+end;
+
+procedure TFPGMap.PutData(Index: Integer; const NewData: TData);
+begin
+  inherited PutData(Index, @NewData);
+end;
+
+procedure TFPGMap.PutKeyData(const AKey: TKey; const NewData: TData);
+begin
+  inherited PutKeyData(@AKey, @NewData);
+end;
+
+procedure TFPGMap.SetOnCompare(NewCompare: TCompareFunc);
+begin
+  FOnCompare := NewCompare;
+  if NewCompare <> nil then
+    OnPtrCompare := @KeyPtrCompare
+  else
+    InitOnPtrCompare;
+end;
+
+function TFPGMap.Add(const AKey: TKey): Integer;
+begin
+  Result := inherited Add(@AKey);
+end;
+
+function TFPGMap.Add(const AKey: TKey; const AData: TData): Integer;
+begin
+  Result := inherited Add(@AKey, @AData);
+end;
+
+function TFPGMap.Find(const AKey: TKey; var Index: Integer): Boolean;
+begin
+  Result := inherited Find(@AKey, Index);
+end;
+
+function TFPGMap.IndexOf(const AKey: TKey): Integer;
+begin
+  Result := inherited IndexOf(@AKey);
+end;
+
+function TFPGMap.IndexOfData(const AData: TData): Integer;
+begin
+  { TODO: loop ? }
+  Result := inherited IndexOfData(@AData);
+end;
+
+procedure TFPGMap.InsertKey(Index: Integer; const AKey: TKey);
+begin
+  inherited InsertKey(Index, @AKey);
+end;
+
+procedure TFPGMap.InsertKeyData(Index: Integer; const AKey: TKey; const AData: TData);
+begin
+  inherited InsertKeyData(Index, @AKey, @AData);
+end;
+
+function TFPGMap.Remove(const AKey: TKey): Integer;
+begin
+  Result := inherited Remove(@AKey);
+end;
+
+{$endif}
 
 end.

rtl/objpas/rtlconst.inc

@@ -178,6 +178,7 @@ ResourceString
   SListCapacityError            = 'List capacity (%d) exceeded.';
   SListCountError               = 'List count (%d) out of bounds.';
   SListIndexError               = 'List index (%d) out of bounds';
+  SListItemSizeError            = 'Incompatible item size in source list';
   SMaskEditErr                  = 'Invalid mask input value.  Use escape key to abandon changes';
   SMaskErr                      = 'Invalid mask input value';
   SMDIChildNotVisible           = 'A MDI-Child Window can not be hidden.';

rtl/objpas/types.pp

@@ -105,6 +105,8 @@ type
   end;
   PSmallPoint = ^TSmallPoint;
 
+  TDuplicates = (dupIgnore, dupAccept, dupError);
+
 type
   TOleChar = WideChar;
   POleStr = PWideChar;
@@ -226,6 +228,9 @@ type
   STATSTG = TStatStg;
   PStatStg = ^TStatStg;
 
+  TListCallback = procedure(data,arg:pointer) of object;
+  TListStaticCallback = procedure(data,arg:pointer);
+
   IClassFactory = Interface(IUnknown) ['{00000001-0000-0000-C000-000000000046}']
      Function CreateInstance(Const unkOuter : IUnknown;Const riid : TGUID;Out vObject) : HResult;StdCall;
      Function LockServer(fLock : LongBool) : HResult;StdCall;

rtl/unix/classes.pp

@@ -28,6 +28,7 @@ uses
   sysutils,
   types,
   typinfo,
+  fgl,
   rtlconsts;
 
 {$i classesh.inc}

utils/h2pas/h2pas.pas

@@ -24,8 +24,10 @@ program h2pas;
 
  ****************************************************************************)
 
+{$message TODO: warning Unit types is only needed due to issue 7910}
+
    uses
-     SysUtils,classes,
+     SysUtils,classes,types,
      options,scan,converu,lexlib,yacclib;
 
    type

utils/h2pas/h2pas.y

@@ -20,8 +20,10 @@ program h2pas;
 
  ****************************************************************************)
 
+{$message TODO: warning Unit types is only needed due to issue 7910}
+
    uses
-     SysUtils,classes,
+     SysUtils,classes,types,
      options,scan,converu,lexlib,yacclib;
 
    type