ソースを参照

+ revive generics based tfplist/tstringlist implementation for generics testing; build with FPC_TESTGENERICS

git-svn-id: trunk@7001 -
micha 18 年 前
コミット
3a1b633325

+ 3 - 0
rtl/amiga/classes.pp

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

+ 3 - 0
rtl/gba/classes.pp

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

+ 3 - 0
rtl/go32v2/classes.pp

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

+ 3 - 0
rtl/morphos/classes.pp

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

+ 3 - 0
rtl/nds/classes.pp

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

+ 3 - 0
rtl/netware/classes.pp

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

+ 3 - 0
rtl/netwlibc/classes.pp

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

+ 13 - 0
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}
@@ -559,6 +567,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^));

+ 3 - 0
rtl/openbsd/classes.pp

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

+ 3 - 0
rtl/os2/classes.pp

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

+ 3 - 0
rtl/unix/classes.pp

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

+ 3 - 0
rtl/watcom/classes.pp

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

+ 3 - 0
rtl/win32/classes.pp

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

+ 3 - 0
rtl/win64/classes.pp

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

+ 3 - 0
rtl/wince/classes.pp

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