Merged revisions 7001-7002,7007,7016,7020-7021,7033,7037,7040,7042,7045,7068-7069,7075-7079,7087,7094,7098-7099,7101,7103,7109,7115-7119,7128,7136-7137,7139,7150,7160-7162,7175,7179,7190-7195,7198,7202,7205-7206,7208-7217,7220-7222,7225-7228,7230,7233,7239-7241,7244,7246,7263,7275,7277,7279-7281,7285,7288-7289,7291-7293,7296,7300-7301,7303,7310,7318,7340-7341,7343,7345,7372-7373,7375-7376,7379,7381,7383-7388,7391-7392,7400,7404-7406,7411,7422,7425,7436,7441-7442,7444-7445,7450,7456,7463,7467,7475,7479,7486,7504,7506-7509,7522,7527,7534-7536,7558-7559,7563-7565,7567,7570-7571,7573-7576,7586,7589,7592-7594,7607,7612,7615,7619-7620,7622-7623,7626,7628,7631,7633,7646,7663,7677,7681-7683,7689,7697,7704-7712,7725,7736,7738,7740,7744-7746,7751,7753,7764,7767,7769-7770,7776-7777,7788,7830,7836-7839,7846,7849,7862,7864-7865,7869,7872,7877,7882,7927-7929,7953,7961,7967,7971,7986-7987,7990-7994,7998-8000,8004-8006,8008-8012,8016,8027,8034,8036-8037,8039,8044,8046,8048,8051,8060,8071,8075-8076,8082-8083,8087-8089,8095-8096,8099-8100,8136,8187,8190,8203,8206-8207,8212-8213,8215,8225,8227,8233-8239,8262,8302,8307,8309,8316,8318-8319,8336,8338-8340,8404,8410-8411,8430-8431,8433,8438-8442,8445-8446,8448,8450-8454,8456-8457,8459,8462,8469-8470,8472-8483,8485 via svnmerge from

http://svn.freepascal.org/svn/fpc/trunk

........
  r7001 | micha | 2007-03-25 21:19:04 +0200 (Sun, 25 Mar 2007) | 1 line
  
  + revive generics based tfplist/tstringlist implementation for generics testing; build with FPC_TESTGENERICS
........
  r7301 | michael | 2007-05-08 15:59:04 +0200 (Tue, 08 May 2007) | 1 line
  
  * Changed check for GENERICCLASSES so fpdoc can parse it correctly
........
  r8431 | tom_at_work | 2007-09-11 23:43:27 +0200 (Tue, 11 Sep 2007) | 1 line
  
  * fix memory leak of TFPSList.Clear()
........
  r8433 | tom_at_work | 2007-09-12 00:23:33 +0200 (Wed, 12 Sep 2007) | 1 line
  
  * better fix for TFPGSList memory leak: avoid changing allocation behavior (adds one temp entry used for various operations), and clean up in the destructor
........
  r8485 | micha | 2007-09-14 22:48:29 +0200 (Fri, 14 Sep 2007) | 2 lines
  
  * fix TFPSMap.GetKeyData on non-sorted map (#9672)
  + add test for issue #9672
........

git-svn-id: branches/fixes_2_2@9003 -

.gitattributes

@@ -8438,6 +8438,7 @@ tests/webtbs/tw9461.pp svneol=native#text/plain
 tests/webtbs/tw9509.pp svneol=native#text/plain
 tests/webtbs/tw9601.pp svneol=native#text/plain
 tests/webtbs/tw9667.pp svneol=native#text/plain
+tests/webtbs/tw9672.pp svneol=native#text/plain
 tests/webtbs/tw9695.pp svneol=native#text/plain
 tests/webtbs/tw9704.pp svneol=native#text/plain
 tests/webtbs/tw9897.pp svneol=native#text/plain

rtl/amiga/classes.pp

@@ -26,6 +26,9 @@ uses
   sysutils,
   rtlconsts,
   types,
+{$ifdef FPC_TESTGENERICS}
+  fgl,
+{$endif}
   typinfo;
 
 {$i classesh.inc}

rtl/gba/classes.pp

@@ -24,6 +24,9 @@ uses
   sysutils,
   rtlconsts,
   types,
+{$ifdef FPC_TESTGENERICS}
+  fgl,
+{$endif}
   typinfo;
 
 {$i classesh.inc}

rtl/go32v2/classes.pp

@@ -26,6 +26,9 @@ uses
   typinfo,
   rtlconsts,
   types,
+{$ifdef FPC_TESTGENERICS}
+  fgl,
+{$endif}
   sysutils;
 
 {$i classesh.inc}

rtl/morphos/classes.pp

@@ -26,6 +26,9 @@ uses
   sysutils,
   rtlconsts,
   types,
+{$ifdef FPC_TESTGENERICS}
+  fgl,
+{$endif}
   typinfo;
 
 {$i classesh.inc}

rtl/netware/classes.pp

@@ -25,6 +25,9 @@ interface
 uses
   sysutils,
   types,
+{$ifdef FPC_TESTGENERICS}
+  fgl,
+{$endif}
   typinfo,
   rtlconsts;
 

rtl/netwlibc/classes.pp

@@ -25,6 +25,9 @@ interface
 uses
   sysutils,
   types,
+{$ifdef FPC_TESTGENERICS}
+  fgl,
+{$endif}
   typinfo,
   rtlconsts,
   Libc;

rtl/objpas/fgl.pp

@@ -80,15 +80,22 @@ type
 
 {$ifndef VER2_0}
 
+const
+  MaxGListSize = MaxInt div 1024;
+
+type
   generic TFPGList<T> = class(TFPSList)
   type public
     TCompareFunc = function(const Item1, Item2: T): Integer;
+    TTypeList = array[0..MaxGListSize] of T;
+    PTypeList = ^TTypeList;
     PT = ^T;
   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  GetList: PTypeList; {$ifdef CLASSESINLINE} inline; {$endif}
     function  ItemPtrCompare(Item1, Item2: Pointer): Integer;
     procedure Put(Index: Integer; const Item: T); {$ifdef CLASSESINLINE} inline; {$endif}
   public
@@ -104,6 +111,7 @@ type
     function Remove(const Item: T): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
     procedure Sort(Compare: TCompareFunc);
     property Items[Index: Integer]: T read Get write Put; default;
+    property List: PTypeList read GetList;
   end;
 
 {$endif}
@@ -207,6 +215,9 @@ end;
 destructor TFPSList.Destroy;
 begin
   Clear;
+  // Clear() does not clear the whole list; there is always a single temp entry
+  // at the end which is never freed. Take care of that one here.
+  FreeMem(FList);
   inherited Destroy;
 end;
 
@@ -307,7 +318,6 @@ begin
   begin
     SetCount(0);
     SetCapacity(0);
-    FList := nil;
   end;
 end;
 
@@ -559,6 +569,11 @@ begin
   Result := T(inherited Get(Index)^);
 end;
 
+function TFPGList.GetList: PTypeList;
+begin
+  Result := PTypeList(FList);
+end;
+
 function TFPGList.ItemPtrCompare(Item1, Item2: Pointer): Integer;
 begin
   Result := FOnCompare(T(Item1^), T(Item2^));
@@ -670,10 +685,11 @@ function TFPSMap.GetKeyData(AKey: Pointer): Pointer;
 var
   I: Integer;
 begin
-  if Find(AKey, I) then
+  I := IndexOf(AKey);
+  if I >= 0 then
     Result := InternalItems[I]+FKeySize
   else
-    Result := nil;
+    Error(SMapKeyError, PtrInt(AKey));
 end;
 
 procedure TFPSMap.InitOnPtrCompare;
@@ -697,7 +713,8 @@ procedure TFPSMap.PutKeyData(AKey: Pointer; NewData: Pointer);
 var
   I: Integer;
 begin
-  if Find(AKey, I) then
+  I := IndexOf(AKey);
+  if I >= 0 then
     Data[I] := NewData
   else
     Add(AKey, NewData);
@@ -721,7 +738,7 @@ begin
       end;
   end else
     Result := Count;
-  CopyKey(AKey, Insert(Result));
+  CopyKey(AKey, inherited Insert(Result));
 end;
 
 function TFPSMap.Add(AKey, AData: Pointer): Integer;
@@ -826,10 +843,9 @@ end;
 
 function TFPSMap.Remove(AKey: Pointer): Integer;
 begin
-  if Find(AKey, Result) then
-    Delete(Result)
-  else
-    Result := -1;
+  Result := IndexOf(AKey);
+  if Result >= 0 then
+    Delete(Result);
 end;
 
 procedure TFPSMap.Sort;

rtl/objpas/rtlconst.inc

@@ -179,6 +179,7 @@ ResourceString
   SListCountError               = 'List count (%d) out of bounds.';
   SListIndexError               = 'List index (%d) out of bounds';
   SListItemSizeError            = 'Incompatible item size in source list';
+  SMapKeyError                  = 'Map key (address $%x) does not exist';
   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/openbsd/classes.pp

@@ -26,6 +26,9 @@ uses
   sysutils,
   rtlconsts,
   types,
+{$ifdef FPC_TESTGENERICS}
+  fgl,
+{$endif}
   typinfo;
 
 {$i classesh.inc}

rtl/os2/classes.pp

@@ -26,6 +26,9 @@ uses
   sysutils,
   rtlconsts,
   types,
+{$ifdef FPC_TESTGENERICS}
+  fgl,
+{$endif}
   typinfo;
 
 {$i classesh.inc}

rtl/unix/classes.pp

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

rtl/watcom/classes.pp

@@ -25,6 +25,9 @@ interface
 uses
   typinfo,
   rtlconsts,
+{$ifdef FPC_TESTGENERICS}
+  fgl,
+{$endif}
   sysutils;
 
 {$i classesh.inc}

rtl/win32/classes.pp

@@ -26,6 +26,9 @@ uses
   rtlconsts,
   sysutils,
   types,
+{$ifdef FPC_TESTGENERICS}
+  fgl,
+{$endif}
   typinfo,
   windows;
 

rtl/win64/classes.pp

@@ -26,6 +26,9 @@ uses
   rtlconsts,
   sysutils,
   types,
+{$ifdef FPC_TESTGENERICS}
+  fgl,
+{$endif}
   typinfo,
   windows;
 

tests/webtbs/tw9672.pp

@@ -0,0 +1,42 @@
+{$mode objfpc} {$H+}
+uses fgl,sysutils;
+
+const strs : array[0..16] of integer = (1,2,2,7,0,12,3,4,5,3,6,7,8,9,0,3,4);
+    
+type
+  TInterestingData = integer;
+  TMySet = specialize TFPGmap<integer, TInterestingData>;
+
+function mycompare(const a,b : integer) : integer;
+begin
+  result := a-b;
+end;
+
+var
+  s : TMySet;
+  idx, i,j : Integer;
+  
+  b : TInterestingData;
+
+begin
+  s := TMySet.Create; 
+  s.sorted := false;
+  s.OnCompare := @mycompare;
+  
+  for i := low(strs) to high(strs) do begin
+    idx := s.IndexOf(strs[i]);
+    writeln('count ', s.count, ' used of ', s.capacity, ' available');
+    if (idx <> -1) then begin
+      b := s[strs[i]];
+    end else begin
+      b := i;
+      s[strs[i]] := b;
+    end;
+    
+    // do something with existing interesting data
+    writeln('data: ', b);
+  end;
+  
+  s.Free;
+end.
+