home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Runimage / Delphi50 / Source / Decision Cube / MXARRAYS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  60.0 KB  |  2,334 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {       Borland Delphi Visual Component Library         }
  4. {                                                       }
  5. {       Copyright (c) 1997,99 Inprise Corporation       }
  6. {                                                       }
  7. {*******************************************************}
  8.  
  9. unit mxarrays;
  10.  
  11. interface
  12.  
  13. uses
  14.   SysUtils, Windows, Classes, mxconsts;
  15.  
  16. type
  17.   { Exceptions }
  18.   EArrayError = class(Exception);
  19.   EUnsupportedTypeError = class(Exception);
  20.   ELowCapacityError = class(Exception);
  21.  
  22.   TCompareProc = function(var item1, item2): Integer;
  23.  
  24.   TSortOrder = (tsNone, tsAscending, tsDescending);
  25.  
  26.   { These flags govern some of the behaviour of array methods }
  27.   TArrayFlags = (afOwnsData, afAutoSize, afCanCompare, afSortUnique);
  28.   TArrayFlagSet = Set of TArrayFlags;
  29.  
  30.   TDuplicates = (dupIgnore, dupAccept, dupError);
  31.  
  32.   TStringItem = record
  33.     FString: string;
  34.     FObject: TObject;
  35.   end;
  36.  
  37.   { This is the base array object that all other array classes inheret from }
  38.  
  39.   TBaseArray = class(TPersistent)
  40.   private
  41.     FMemory: Pointer;           { Pointer to item buffer }
  42.     FCapacity: Integer;         { The allocated size of the array }
  43.     FItemSize: Integer;         { Size of individual item in bytes }
  44.     FCount: Integer;            { Count of items in use }
  45.     FSortOrder: TSortOrder;     { True if array is considered sorted }
  46.     FFlags: TArrayFlagSet;      { Ability flags }
  47.     FDuplicates: TDuplicates;   { Signifies if duplicates are stored or not }
  48.     FCompProc: TCompareProc;
  49.     function GetItemPtr(index: Integer): Pointer;
  50.     procedure CopyFrom(toIndex, numItems: Integer; var Source);
  51.     procedure SetCount(NewCount: Integer);
  52.     function GetLimit: Integer;
  53.   protected
  54.     function ValidIndex(Index: Integer): Boolean;
  55.     function HasFlag(aFlag: TArrayFlags): Boolean;
  56.     procedure SetFlag(aFlag: TArrayFlags);
  57.     procedure ClearFlag(aFlag: TArrayFlags);
  58.     procedure SetAutoSize(aSize: Boolean);
  59.     procedure BlockCopy(Source: TBaseArray; fromIndex, toIndex, numitems: Integer);
  60.     function GetAutoSize: Boolean;
  61.     function ValidateBounds(atIndex: Integer; var numItems: Integer): Boolean;
  62.     procedure RemoveRange(atIndex, numItems: Integer);
  63.     procedure InternalHandleException;
  64.     procedure InvalidateItems(atIndex, numItems: Integer); virtual;
  65.     procedure SetCapacity(NewCapacity: Integer); virtual;
  66.     procedure Grow; virtual;
  67.   public
  68.     constructor Create(itemcount, iSize: Integer); virtual;
  69.     destructor Destroy; override;
  70.     procedure Clear;
  71.     procedure InsertAt(Index: Integer; var Value);
  72.     procedure Insert(Index: Integer; var Value); virtual;
  73.     procedure PutItem(index: Integer; var Value);
  74.     procedure GetItem(index: Integer; var Value);
  75.     procedure RemoveItem(Index: Integer);
  76.     procedure Delete(Index: Integer); virtual;
  77.     procedure Exchange(Index1, Index2: Integer); virtual;
  78.     function IndexOf(var Item): Integer; virtual;
  79.     function FindItem(var Index: Integer; var Value): Boolean;
  80.     procedure Sort(Compare: TCompareProc); virtual;
  81.     property CompareProc: TCompareProc read FCompProc write FCompProc;
  82.     property Duplicates: TDuplicates read FDuplicates write FDuplicates;
  83.     property SortOrder: TSortOrder read FSortOrder write FSortOrder;
  84.     property Capacity: Integer read FCapacity write SetCapacity;
  85.     property Limit: Integer read GetLimit write SetCapacity;  
  86.     property ItemSize: Integer read FItemSize;
  87.     property AutoSize: Boolean read GetAutoSize write SetAutoSize;
  88.     property Count: Integer read FCount write SetCount;
  89.     property List: Pointer read FMemory;
  90.   end;
  91.  
  92.   TSmallIntArray = class(TBaseArray)
  93.   public
  94.     constructor Create(itemcount, dummy: Integer); override;
  95.     procedure PutItem(index: Integer; value: SmallInt);
  96.     function GetItem(index: Integer): SmallInt;
  97.     function Add(Value: SmallInt): Integer;
  98.     procedure Assign(Source: TPersistent); override;
  99.     property Items[Index:Integer]: SmallInt read GetItem write PutItem; default;
  100.   end;
  101.  
  102.   TIntArray = class(TBaseArray)
  103.   public
  104.     constructor Create(itemcount, dummy: Integer); override;
  105.     procedure PutItem(index: Integer; value: Integer);
  106.     function GetItem(index: Integer): Integer;
  107.     function Add(Value: Integer): Integer;
  108.     procedure Assign(Source: TPersistent); override;
  109.     function Find(var Index: Integer; Value: Integer): Boolean;
  110.     property Items[Index: Integer]: Integer read GetItem write PutItem; default;
  111.   end;
  112.  
  113.   TSingleArray = class(TBaseArray)
  114.   public
  115.     constructor Create(itemcount, dummy: Integer); override;
  116.     procedure PutItem(index: Integer; value: Single);
  117.     function GetItem(index: Integer): Single;
  118.     function Add(Value: Single): Integer;
  119.     function Find(var Index: Integer; Value: Single): Boolean;
  120.     function IndexOf(var Item): Integer; override;
  121.     procedure Assign(Source: TPersistent); override;
  122.     property Items[Index: Integer]: Single read GetItem write PutItem; default;
  123.   end;
  124.  
  125.   TDoubleArray = class(TBaseArray)
  126.   public
  127.     constructor Create(itemcount, dummy: Integer); override;
  128.     procedure PutItem(index: Integer; value: Double);
  129.     function GetItem(index: Integer): Double;
  130.     function Add(Value: Double): Integer;
  131.     function Find(var Index: Integer; Value: Double): Boolean;
  132.     function IndexOf(var Item): Integer; override;
  133.     procedure Assign(Source: TPersistent); override;
  134.     property Items[Index: Integer]: Double read GetItem write PutItem; default;
  135.   end;
  136.  
  137.   TCurrencyArray = class(TBaseArray)
  138.   public
  139.     constructor Create(itemcount, dummy: Integer); override;
  140.     procedure PutItem(index: Integer; value: Currency);
  141.     function GetItem(index: Integer): Currency;
  142.     function Add(Value: Currency): Integer;
  143.     function Find(var Index: Integer; Value: Currency): Boolean;
  144.     function IndexOf(var Item): Integer; override;
  145.     procedure Assign(Source: TPersistent); override;
  146.     property Items[Index: Integer]: Currency read GetItem write PutItem; default;
  147.   end;
  148.  
  149.   TWordArray = class(TBaseArray)
  150.   public
  151.     constructor Create(itemcount, dummy: Integer); override;
  152.     procedure PutItem(index: Integer; value: Word);
  153.     function GetItem(index: Integer): Word;
  154.     function Add(Value: Word): Integer;
  155.     function Find(var Index: Integer; Value: Word): Boolean;
  156.     function IndexOf(var Item): Integer; override;
  157.     procedure Assign(Source: TPersistent); override;
  158.     property Items[Index: Integer]: Word read GetItem write PutItem; default;
  159.   end;
  160.  
  161.   TPointerArray = class(TBaseArray)
  162.   public
  163.     constructor Create(itemcount, dummy: Integer); override;
  164.     procedure PutData(index: Integer; value: Pointer);
  165.     function GetData(index: Integer): Pointer;
  166.     procedure CopyFrom(var Source; toIndex, numItems: Integer);
  167.     procedure CopyTo(var Dest; fromIndex, numItems: Integer);
  168.     procedure InvalidateItems(atIndex, numItems: Integer); override;
  169.     function CloneItem(item: Pointer): Pointer; virtual;
  170.     procedure FreeItem(item: Pointer); virtual;
  171.     property AsPtr[Index: Integer]: Pointer read GetData write PutData;
  172.     property Data[Index: Integer]: Pointer read GetData write PutData;
  173.   end;
  174.  
  175.   TStringArray = class(TBaseArray)
  176.   private
  177.     procedure ExchangeItems(Index1, Index2: Integer);
  178.     procedure QuickSort(L, R: Integer);
  179.     procedure InsertItem(Index: Integer; const S: string);
  180.     procedure AddStrings(Strings: TStringArray);
  181.   protected
  182.     function GetString(Index: Integer): string;
  183.     procedure PutString(Index: Integer; const S: string);
  184.     function GetObject(Index: Integer): TObject;
  185.     procedure PutObject(Index: Integer; AObject: TObject);
  186.     procedure InvalidateItems(atIndex, numItems: Integer); override;
  187.     procedure Grow; override;
  188.   public
  189.     constructor Create(itemcount, dummy: Integer);override;
  190.     function Add(const S: String): Integer;
  191.     procedure Assign(Source: TPersistent); override;
  192.     procedure Exchange(Index1, Index2: Integer); override;
  193.     function Find(S: string; var Index: Integer): Boolean;
  194.     function IndexOf(var Item): Integer; override;
  195.     procedure Sort(Compare: TCompareProc); override;
  196.     procedure Insert(Index: Integer; var Value); override;
  197.     property Strings[Index: Integer]: String read GetString write PutString; default;
  198.   end;
  199.  
  200. Const
  201.   vMaxRow = (High(Integer)-$f) div Sizeof(SmallInt);
  202.   vMaxCol = High(Integer) div Sizeof(TSmallIntArray)-1;
  203.  
  204. type
  205.   TMatrixNDX = 0..vMaxCol;
  206.   TDynArrayNDX = 0..vMaxRow;
  207.   TMatrixElements = array[TMatrixNDX] of TSmallIntArray;
  208.   PMatrixElements = ^TMatrixElements;
  209.  
  210.   EDynArrayRangeError = class(ERangeError);
  211.  
  212.   TTwoDimArray = class
  213.   Private
  214.     FRows: TDynArrayNDX;
  215.     FColumns: TMatrixNDX;
  216.     FMemAllocated: Integer;
  217.     function GetElement(row: TDynArrayNDX; column: TMatrixNDX): SmallInt;
  218.     procedure SetElement(row: TDynArrayNDX; column: TMatrixNDX; const NewValue: SmallInt);
  219.   Protected
  220.     mtxElements: PMatrixElements;
  221.   Public
  222.     constructor Create;
  223.     Destructor Destroy; override;
  224.     procedure SetSize(NumRows: TDynArrayNDX; NumColumns: TMatrixNDX);
  225.     Property rows: TDynArrayNDX read FRows;
  226.     Property columns: TMatrixNDX read FColumns;
  227.     Property Element[row: TDynArrayNDX; column: TMatrixNDX]: SmallInt read GetElement write SetElement; default;
  228.   end;
  229.  
  230.   TIndexNDX = 0..vMaxCol;
  231.   TIndexElements = array[TIndexNDX] of TSmallIntArray;
  232.   PIndexElements = ^TIndexElements;
  233.  
  234.   TIndexArray = class
  235.   Private
  236.     FMemAllocated: Integer;
  237.     FCount: Integer;
  238.     FCapacity: TIndexNDX;
  239.     FAutosize: Boolean;
  240.     function GetElement(Element: TIndexNDx): TSmallIntArray;
  241.     procedure SetElement(Element: TIndexNDX; const NewValue: TSmallIntArray);
  242.   Protected
  243.     idxElements: PIndexElements;
  244.   Public
  245.     constructor Create;
  246.     Destructor Destroy; override;
  247.     procedure SetSize(Elements: TIndexNDX);
  248.     procedure Expand;
  249.     function Add(const NewValue: TSmallIntArray): Integer;
  250.     property MemoryUsage: Integer read FMemAllocated;
  251.     property Autosize: Boolean read FAutosize write FAutosize;
  252.     property Capacity: TIndexNDX read FCapacity write SetSize;
  253.     property Count: Integer read FCount;
  254.     Property Items[Element: TIndexNDX]: TSmallIntArray read GetElement write SetElement; default;
  255.   end;
  256.  
  257.   TCustomArray = class
  258.   private
  259.     FDataType: Integer;      { The variant data type }
  260.     FArray: Pointer;      { Pointer to the array class }
  261.     FBlankStringVal: string;
  262.     FBlankDateVal: Variant;
  263.     FBlankBoolVal: Word;
  264.     FBlankCount: Integer;
  265.     procedure UnsupportedTypeError(vType: Integer);
  266.   protected
  267.     function GetItem(Index: Integer): Variant;
  268.     procedure SetItem(Index: Integer; Value: Variant);
  269.     function GetCompProc: TCompareProc;
  270.     procedure SetCompProc(Proc: TCompareProc);
  271.     function GetMemberCount: Integer;
  272.     function GetSort: Boolean;
  273.     procedure SetSort(Value: Boolean);
  274.     function GetDups: TDuplicates;
  275.     procedure SetDups(Value: TDuplicates);
  276.   public
  277.     constructor Create(Items: Integer; VarType: Integer);
  278.     destructor Destroy; override;
  279.     function ConvertVar(Value: Variant): Variant;
  280.     function Add(Value: Variant): Integer;
  281.     function IsBlank(Index: Integer): Boolean;
  282.     function MemoryUsage: Integer; virtual;
  283.     procedure SetSize(size: Integer);
  284.     function IndexOf(Value: Variant): Integer;
  285.     procedure Assign(Value: TCustomArray; bSorted, bUnique: Boolean);
  286.     function GetDouble(Index: Integer): Double;
  287.     function GetCurrency(Index: Integer): Currency;
  288.     function GetInteger(Index: Integer): Integer;
  289.     property List: Pointer read FArray;
  290.     property Duplicates: TDuplicates read GetDups write SetDups;
  291.     property Sorted: Boolean read GetSort write SetSort;
  292.     property BlankStringVal: string read FBlankStringVal write FBlankStringVal;
  293.     property BlankDateVal: Variant read FBlankDateVal write FBlankDateVal;
  294.     property BlankBoolVal: Word read FBlankBoolVal write FBlankBoolVal;
  295.     property CompareProc: TCompareProc read GetCompProc write SetCompProc;
  296.     property MemberCount: Integer read GetMemberCount;
  297.     property DataType: Integer read FDataType;
  298.     property BlankCount: Integer read FBlankCount;
  299.     property Items[I: Integer]: Variant read GetItem write SetItem; default;
  300.   end;
  301.  
  302.   TThreadCustomArray = class
  303.   private
  304.     FCustomArray: TCustomArray;
  305.     FLock: TRTLCriticalSection;
  306.   public
  307.     constructor Create(Items: Integer; VarType: Integer);
  308.     destructor Destroy; override;
  309.     function Add(Item: Variant): Integer;
  310.     function LockArray: TCustomArray;
  311.     function GetItem(Index: Integer): Variant;
  312.     function MemoryUsage: Integer;
  313.     procedure UnlockArray;
  314.   end;
  315.  
  316.   procedure SetMemoryCapacity(Value: Integer);
  317.   function GetMemoryCapacity: Integer;
  318.  
  319. implementation
  320.  
  321.   { Helper functions }
  322.  
  323. var
  324.   AvailableMemory: Integer;       { Memory available to allocate }
  325.   TotalAllocatedMemory: Integer;  { Total allaocted by the array classes }
  326.  
  327. function GetAvailableMem: Integer;
  328. var
  329.   MemStats: TMemoryStatus;
  330. begin
  331.   GlobalMemoryStatus(MemStats);
  332.   Result := MemStats.dwAvailPhys + (MemStats.dwAvailPageFile div 2);
  333. end;
  334.  
  335. procedure SetMemoryCapacity(Value: Integer);
  336. begin
  337.   AvailableMemory := Value;
  338. end;
  339.  
  340. function GetMemoryCapacity: Integer;
  341. begin
  342.   Result := AvailableMemory;
  343. end;
  344.  
  345. function CheckLowCapacity(oldSize, newSize: Integer): Boolean;
  346. var
  347.   CheckMemSize: Integer;
  348. begin
  349.   Result := False;
  350.   Dec(TotalAllocatedMemory, oldSize);
  351.   CheckMemSize := AllocMemSize;
  352.   Inc(CheckMemSize, newSize);
  353.   if (CheckMemSize > AvailableMemory) then Result := True;
  354. end;
  355.  
  356. procedure LowCapacityError;
  357. begin
  358.   raise ELowCapacityError.CreateRes(@sLowCapacityError);
  359. end;
  360.  
  361. function CmpWord(var item1, item2): Integer;
  362. var
  363.   w1: word absolute item1;
  364.   w2: word absolute item2;
  365.   i1, i2: Integer;
  366. begin
  367.   if (w1 = 2) then
  368.     i1 := -1
  369.   else
  370.     i1 := Integer(w1);
  371.  
  372.   if (w2 = 2) then
  373.     i2 := -1
  374.   else
  375.     i2 := Integer(w2);
  376.  
  377.   if (i1 < i2) then
  378.     Result := -1
  379.   else if (i1 > i2) then
  380.     Result := 1
  381.   else
  382.     Result := 0;
  383. end;
  384.  
  385. function CmpSmallInt(var item1, item2): Integer;
  386. var
  387.   i1: SmallInt absolute item1;
  388.   i2: SmallInt absolute item2;
  389. begin
  390.   Result := i1-i2;
  391. end;
  392.  
  393. function CmpInteger(var item1, item2): Integer;
  394. var
  395.   i1: Integer absolute item1;
  396.   i2: Integer absolute item2;
  397. begin
  398.   if (i1 < i2) then
  399.     Result := -1
  400.   else if (i1 > i2) then
  401.     Result := 1
  402.   else
  403.     Result := 0;
  404. end;
  405.  
  406. function CmpSingle(var item1, item2): Integer;
  407. var
  408.   i1: Single absolute item1;
  409.   i2: Single absolute item2;
  410.   r: Single;
  411. begin
  412.   r := i1-i2;
  413.   if (Abs(r) < 1.0E-30) then
  414.     Result := 0
  415.   else if (r < 0) then
  416.     Result := -1
  417.   else
  418.     Result := 1;
  419. end;
  420.  
  421. function CmpDouble(var item1, item2): Integer;
  422. var
  423.   i1: Double absolute item1;
  424.   i2: Double absolute item2;
  425.   r: Double;
  426. begin
  427.   r := i1-i2;
  428.   if (Abs(r) < 1.0E-100) then
  429.     Result := 0
  430.   else if (r < 0) then
  431.     Result := -1
  432.   else
  433.     Result := 1;
  434. end;
  435.  
  436. function CmpCurrency(var item1, item2): Integer;
  437. var
  438.   i1: Currency absolute item1;
  439.   i2: Currency absolute item2;
  440.   r:  Currency;  
  441. begin
  442.   r := i1-i2;  
  443.   if (Abs(r) < 1.0E-3000) then
  444.     Result := 0
  445.   else if (r < 0) then
  446.     Result := -1
  447.   else
  448.     Result := 1;
  449. end;
  450.  
  451. function CmpString(var item1, item2): Integer;
  452. var
  453.   p1: String absolute item1;
  454.   p2: String absolute item2;
  455. begin
  456.   Result := AnsiCompareStr(p1, p2);
  457. end;
  458.  
  459. procedure ArrayDuplicateError;
  460. begin
  461.   raise EArrayError.CreateRes(@sDupeItem);
  462. end;
  463.  
  464. procedure ArrayIndexError(Index: Integer);
  465. begin
  466.   raise EArrayError.CreateResFMT(@sArrayIndexOutOfRange, [Index]);
  467. end;
  468.  
  469.   { TBaseArray class }
  470.  
  471. constructor TBaseArray.Create(itemcount, iSize: Integer);
  472. begin
  473.   inherited Create;
  474.   FMemory := nil;
  475.   FCapacity := 0;
  476.   FCount := 0;
  477.   FItemSize := iSize;
  478.   FFlags := [afOwnsData, afAutoSize];
  479.  
  480.   SetCapacity(itemcount);
  481. end;
  482.  
  483. destructor TBaseArray.Destroy;
  484. begin
  485.   if (FMemory <> nil) then
  486.   begin
  487.     Clear;
  488.     FItemSize := 0;
  489.   end;
  490.   inherited Destroy;
  491. end;
  492.  
  493. procedure TBaseArray.SetCount(NewCount: Integer);
  494. begin
  495.   if (NewCount < 0) or (NewCount > MaxListSize) then
  496.     ArrayIndexError(NewCount);
  497.   if (NewCount > FCapacity) then
  498.     SetCapacity(NewCount);
  499.   if (NewCount > FCount) then
  500.     FillMemory(GetItemPtr(FCount), (NewCount - FCount) * FItemSize, 0);    
  501.   FCount := NewCount;
  502. end;
  503.  
  504. procedure TBaseArray.Clear;
  505. begin
  506.   if (FCount <> 0) then
  507.   begin
  508.     InvalidateItems(0, FCount);
  509.     FCount := 0;
  510.     SetCapacity(0);  { Has same affect as freeing memory }
  511.   end;
  512. end;
  513.  
  514. procedure TBaseArray.SetCapacity(NewCapacity: Integer);
  515. begin
  516.   if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
  517.     ArrayIndexError(NewCapacity);
  518.   if (NewCapacity <> FCapacity) then
  519.   begin
  520.     { Check for available memory }
  521.     if CheckLowCapacity((FCapacity * FItemSize), NewCapacity * FItemSize) then
  522.       LowCapacityError;
  523.     ReallocMem(FMemory, NewCapacity * FItemSize);
  524.     FillChar(Pointer(Integer(FMemory) + FCapacity * FItemSize)^, (NewCapacity - FCapacity) * FItemSize, 0);
  525.     FCapacity := NewCapacity;
  526.   end;
  527. end;
  528.  
  529. procedure TBaseArray.Grow;
  530. var
  531.   Delta: Integer;  
  532. begin
  533.   if (FCapacity > 64) then
  534.     Delta := FCapacity div 4
  535.   else if (FCapacity > 8) then
  536.     Delta := 16
  537.   else
  538.     Delta := 4;    
  539.   SetCapacity(FCapacity + Delta);
  540. end;
  541.  
  542. function TBaseArray.GetLimit: Integer;
  543. begin
  544.   if (FCount = 0) then
  545.     Result := FCapacity
  546.   else
  547.     Result := FCount;
  548. end;
  549.  
  550. procedure TBaseArray.Insert(Index: Integer; var Value);
  551. begin
  552.   InsertAt(Index, Value);
  553. end;
  554.  
  555. procedure TBaseArray.InsertAt(Index: Integer; var Value);
  556. begin
  557.   if (Index < 0) or (Index > FCount) then
  558.     ArrayIndexError(Index);
  559.   { Increase the array size if needed }
  560.   if AutoSize then
  561.     SetCapacity(FCount+1);
  562.   if (Index < FCount) then
  563.   begin
  564.     try
  565.       MoveMemory(GetItemPtr(Index+1), GetItemPtr(Index), (FCount - Index) * FItemSize);
  566.     except
  567.       InternalHandleException;
  568.     end;
  569.   end;
  570.   CopyFrom(Index, 1, Value);
  571.   Inc(FCount);
  572. end;
  573.  
  574. function TBaseArray.ValidIndex(Index: Integer): Boolean;
  575. begin
  576.   Result := True;  
  577.   if (Index < 0) or (Index > FCount) then
  578.   begin
  579.     ArrayIndexError(Index);
  580.     Result := False;
  581.   end
  582. end;
  583.  
  584. procedure TBaseArray.RemoveItem(Index: Integer);
  585. begin
  586.   Delete(Index);
  587. end;
  588.  
  589. procedure TBaseArray.Delete(Index: Integer);
  590. begin
  591.   { We are removing only one item. }
  592.   if ValidIndex(index) then
  593.   begin
  594.     InvalidateItems(Index, 1);
  595.     Dec(FCount);
  596.     if (Index < FCount) then
  597.     begin
  598.       try
  599.         MoveMemory(GetItemPtr(Index), GetItemPtr(Index + 1), (FCount - Index) * FItemSize);
  600.       except
  601.       end;
  602.     end;
  603.   end;
  604. end;
  605.  
  606. procedure TBaseArray.RemoveRange(atIndex, numItems: Integer);
  607. begin
  608.   if (numItems = 0) then
  609.     Exit;
  610.   if ValidateBounds(atIndex, numItems) then
  611.   begin
  612.     { Invalidate the items about to be deleted so a derived class can do cleanup on them. }
  613.     InvalidateItems(atIndex, numItems);
  614.     { Move the items above those we delete down, if there are any }
  615.     if ((atIndex+numItems) <= FCount) then
  616.     begin
  617.       MoveMemory(GetItemPtr(atIndex), GetItemPtr(atIndex+numItems),
  618.                 (FCount-atIndex-numItems+1)* FItemSize);
  619.     end;
  620.     if AutoSize then
  621.       SetCapacity(FCount - numItems);
  622.   end;
  623. end;
  624.  
  625. procedure TBaseArray.Exchange(Index1, Index2: Integer);
  626. begin
  627. end;
  628.  
  629. procedure TBaseArray.Sort(Compare: TCompareProc);
  630. begin
  631. end;
  632.  
  633. procedure TBaseArray.CopyFrom(toIndex, numItems: Integer; var Source);
  634. begin
  635.   if (numItems = 0) then Exit;
  636.   if ValidateBounds(toIndex, numItems) then
  637.   begin
  638.     try
  639.       InvalidateItems(toIndex, numItems);
  640.       MoveMemory(GetItemPtr(toIndex), @Source, numItems*FItemSize);
  641.     except
  642.       InternalHandleException;
  643.     end;
  644.   end;
  645. end;
  646.  
  647. procedure TBaseArray.PutItem(index: Integer; var Value);
  648. begin
  649.   if AutoSize and (FCount = FCapacity) then
  650.     Grow;
  651.   if ValidIndex(index) then
  652.   begin
  653.     try
  654.       CopyMemory(GetItemPtr(index), @Value, FItemSize);
  655.     except
  656.       InternalHandleException;
  657.     end;
  658.     if index > FCount-1 then
  659.       Inc(FCount);
  660.   end;
  661. end;
  662.  
  663. procedure TBaseArray.GetItem(index: Integer; var Value);
  664. begin
  665.   if ValidIndex(index) then
  666.   begin
  667.     try
  668.       CopyMemory(@Value, GetItemPtr(index), FItemSize);
  669.     except
  670.       InternalHandleException;
  671.     end;
  672.   end;
  673. end;
  674.  
  675. function TBaseArray.GetItemPtr(index: Integer): Pointer;
  676. begin
  677.   Result := nil;  
  678.   if ValidIndex(index) then
  679.     Result := Ptr(LongInt(FMemory) + (index*FItemSize));
  680. end;
  681.  
  682. function TBaseArray.ValidateBounds(atIndex: Integer; var numItems: Integer): Boolean;
  683. begin
  684.   Result := True;
  685.   if (atIndex < 0) or (atIndex > FCount) then
  686.     Result := False;
  687.   if Result then
  688.     if (numItems > Succ(FCount)) or ((FCount-numItems+1) < atIndex) then
  689.       numItems := FCount - atIndex + 1;
  690. end;
  691.  
  692. procedure TBaseArray.InvalidateItems(atIndex, numItems: Integer);
  693. begin
  694. end;
  695.  
  696. function TBaseArray.HasFlag(aFlag: TArrayFlags): Boolean;
  697. begin
  698.    Result := aFlag in FFlags;
  699. end;
  700.  
  701. procedure TBaseArray.SetFlag(aFlag: TArrayFlags);
  702. begin
  703.    Include(FFLags, aFlag);
  704. end;
  705.  
  706. procedure TBaseArray.ClearFlag(aFlag: TArrayFlags);
  707. begin
  708.    Exclude(FFLags, aFlag);
  709. end;
  710.  
  711. procedure TBaseArray.SetAutoSize(aSize: Boolean);
  712. begin
  713.   if (aSize = True) then
  714.     SetFlag(afAutoSize)
  715.   else
  716.     ClearFlag(afAutoSize);
  717. end;
  718.  
  719. function TBaseArray.GetAutoSize : Boolean;
  720. begin
  721.   Result := HasFlag(afAutoSize);
  722. end;
  723.  
  724. function TBaseArray.IndexOf(var Item): Integer;
  725. var
  726.   item2: Pointer;  
  727. begin
  728.   if (SortOrder = tsNone) then
  729.   begin
  730.     for Result := 0 to Count - 1 do
  731.     begin
  732.       GetItem(Result, item2);
  733.       
  734.       if (FCompProc(item2, Item) = 0) then
  735.         Exit;
  736.     end;
  737.     Result := -1;
  738.   end
  739.   else
  740.     if not FindItem(Result, Item) then
  741.       Result := -1;
  742. end;
  743.  
  744. function TBaseArray.FindItem(var Index: Integer; var Value): Boolean;
  745. var
  746.   L, H, I, C: Integer;
  747.   Value2: Pointer;  
  748. begin
  749.   Result := False;
  750.   L := 0;
  751.   H := Count - 1;  
  752.   while (L <= H) do
  753.   begin
  754.     I := (L + H) shr 1;
  755.     GetItem(I, Value2);
  756.     C := FCompProc(Value2, Value);
  757.     if (C < 0) then
  758.       L := I + 1
  759.     else
  760.     begin
  761.       H := I - 1;
  762.       if (C = 0) then
  763.       begin
  764.         Result := True;
  765.         if (Duplicates <> dupAccept) then
  766.           L := I;
  767.       end;
  768.     end;
  769.   end;
  770.   Index := L;
  771. end;
  772.  
  773. procedure TBaseArray.BlockCopy(Source: TBaseArray; fromIndex, toIndex, numitems: Integer);
  774. begin
  775.   if (numitems = 0) then Exit;
  776.   if (Source is ClassType) and (ItemSize = Source.ItemSize) then
  777.   begin
  778.     if Source.ValidateBounds(fromIndex, numItems) then
  779.     begin
  780.       try
  781.         CopyFrom(toIndex, numItems, Source.GetItemPtr(fromIndex)^);
  782.       except
  783.         InternalHandleException;
  784.       end;
  785.     end;
  786.   end;
  787. end;
  788.  
  789. procedure TBaseArray.InternalHandleException;
  790. begin
  791.   Clear;  
  792.   raise EArrayError.CreateRes(@sGeneralArrayError);
  793. end;
  794.  
  795.   { TIntArray }
  796.  
  797. type
  798.   TIArray = Array[0..High(Integer) div Sizeof(Integer)-1] of Integer;
  799.   PIntArray = ^TIArray;
  800.  
  801. constructor TIntArray.Create(itemcount, dummy: Integer);
  802. begin
  803.   inherited Create(itemcount, Sizeof(integer));
  804.   FCompProc := CmpInteger;
  805. end;
  806.  
  807. procedure TIntArray.PutItem(index: Integer ; value: Integer);
  808. begin
  809.   if AutoSize and (FCount = FCapacity) then inherited Grow;
  810.   try
  811.     PIntArray(FMemory)^[index] := value;
  812.   except
  813.     InternalHandleException;
  814.   end;  
  815.   if (index > FCount-1) then Inc(FCount);
  816. end;
  817.  
  818. function TIntArray.GetItem(index: Integer): Integer;
  819. begin
  820.   Result := 0;
  821.   if ValidIndex(index) then
  822.   begin
  823.     try
  824.       Result := PIntArray(FMemory)^[index];
  825.     except
  826.       InternalHandleException;
  827.     end;
  828.   end;
  829. end;
  830.  
  831. function TIntArray.Add(Value: Integer): Integer;
  832. begin
  833.   if (SortOrder = tsNone) then
  834.     Result := FCount
  835.   else
  836.     if FindItem(Result, Value) then
  837.       case Duplicates of
  838.         dupIgnore : Exit;
  839.         dupError  : ArrayDuplicateError;
  840.       end;
  841.   InsertAt(Result, Value);
  842. end;
  843.  
  844. procedure TIntArray.Assign(Source: TPersistent);
  845. var
  846.   I: Integer;  
  847. begin
  848.   if (Source is TIntArray) then
  849.   begin
  850.     try
  851.       Clear;
  852.       for I := 0 to TBaseArray(Source).Count - 1 do
  853.         Add(TIntArray(Source)[I]);
  854.     finally
  855.     end;
  856.     Exit;
  857.   end;
  858.   inherited Assign(Source);
  859. end;
  860.  
  861. function TIntArray.Find(var Index: Integer; Value: Integer): Boolean;
  862. var
  863.   L, H, I, C: Integer;
  864.   Value2: Integer;  
  865. begin
  866.   Result := False;
  867.   L := 0;
  868.   H := Count - 1;
  869.   while (L <= H) do
  870.   begin
  871.     I := (L + H) shr 1;
  872.     Value2 := GetItem(I);
  873.     C := FCompProc(Value2, Value);
  874.     if (C < 0) then
  875.       L := I + 1
  876.     else
  877.     begin
  878.       H := I - 1;
  879.       if (C = 0) then
  880.       begin
  881.         Result := True;
  882.         if (Duplicates <> dupAccept) then
  883.           L := I;
  884.       end;
  885.     end;
  886.   end;
  887.   Index := L;
  888. end;
  889.  
  890.   { TSingleArray }
  891.  
  892. Type
  893.   TRArray = Array[0..High(Integer) div Sizeof(Single)-1] of Single;
  894.   PSingleArray = ^TRArray;
  895.  
  896. constructor TSingleArray.Create(itemcount, dummy: Integer);
  897. begin
  898.   inherited Create(itemcount, Sizeof(Single));
  899.   FCompProc := CmpSingle;
  900. end;
  901.  
  902. procedure TSingleArray.PutItem(index: Integer ; value: Single);
  903. begin
  904.   if AutoSize and (FCount = FCapacity) then
  905.     inherited Grow;     
  906.   try
  907.     PSingleArray(FMemory)^[index] := value;
  908.   except
  909.     InternalHandleException;
  910.   end;
  911.   if (index > FCount-1) then
  912.     Inc(FCount);
  913. end;
  914.  
  915. function TSingleArray.GetItem(index: Integer): Single;
  916. begin
  917.   Result := 0;
  918.   if ValidIndex(index) then
  919.   begin
  920.     try
  921.       Result := PSingleArray(FMemory)^[index];
  922.     except
  923.       InternalHandleException;
  924.     end;
  925.   end;
  926. end;
  927.  
  928. function TSingleArray.Add(Value: Single): Integer;
  929. begin
  930.   if (SortOrder = tsNone) then
  931.     Result := FCount
  932.   else
  933.     if FindItem(Result, Value) then
  934.       case Duplicates of
  935.         dupIgnore : Exit;
  936.         dupError  : ArrayDuplicateError;
  937.       end;
  938.   InsertAt(Result, Value);
  939. end;
  940.  
  941. procedure TSingleArray.Assign(Source: TPersistent);
  942. var
  943.   I: Integer;  
  944. begin
  945.   if (Source is TSingleArray) then
  946.   begin
  947.     try
  948.       Clear;
  949.       for I := 0 to TBaseArray(Source).Count - 1 do
  950.         Add(TSingleArray(Source)[I]);
  951.     finally
  952.     end;
  953.     Exit;
  954.   end;
  955.   inherited Assign(Source);
  956. end;
  957.  
  958. function TSingleArray.Find(var Index: Integer; Value: Single): Boolean;
  959. var
  960.   L, H, I, C: Integer;
  961.   Value2: Single;
  962. begin
  963.   Result := False;
  964.   L := 0;
  965.   H := Count - 1;
  966.   while (L <= H) do
  967.   begin
  968.     I := (L + H) shr 1;
  969.     Value2 := GetItem(I);
  970.     C := FCompProc(Value2, Value);
  971.     if (C < 0) then
  972.       L := I + 1
  973.     else
  974.     begin
  975.       H := I - 1;
  976.       if (C = 0) then
  977.       begin
  978.         Result := True;
  979.         if (Duplicates <> dupAccept) then
  980.           L := I;
  981.       end;
  982.     end;
  983.   end;
  984.   Index := L;
  985. end;
  986.  
  987. function TSingleArray.IndexOf(var Item): Integer;
  988. var
  989.   item1: Single absolute Item;
  990.   item2: Single;
  991. begin
  992.   if (SortOrder = tsNone) then
  993.   begin
  994.     for Result := 0 to Count - 1 do
  995.     begin
  996.       item2 := GetItem(Result);
  997.       if (FCompProc(item2, item1) = 0) then
  998.         Exit;
  999.     end;
  1000.     Result := -1;
  1001.   end
  1002.   else
  1003.     if not Find(Result, item1) then
  1004.       Result := -1;
  1005. end;
  1006.  
  1007.   { TDoubleArray }
  1008.  
  1009. type
  1010.   TDArray = array[0..High(Integer) div Sizeof(Double)-1] of Double;
  1011.   PDoubleArray = ^TDArray;
  1012.  
  1013. constructor TDoubleArray.Create(itemcount, dummy: Integer);
  1014. begin
  1015.   inherited Create(itemcount, Sizeof(Double));
  1016.   FCompProc := CmpDouble;
  1017. end;
  1018.  
  1019. procedure TDoubleArray.PutItem(index: Integer ; value: Double);
  1020. begin
  1021.   if AutoSize and (FCount = FCapacity) then
  1022.     inherited Grow;
  1023.   try
  1024.     PDoubleArray(FMemory)^[index] := value;
  1025.   except
  1026.     InternalHandleException;
  1027.   end;
  1028.   if (index > FCount-1) then Inc(FCount);
  1029. end;
  1030.  
  1031. function TDoubleArray.GetItem(index: Integer): Double;
  1032. begin
  1033.   Result := 0;
  1034.   if ValidIndex(index) then
  1035.   begin
  1036.     try
  1037.       Result := PDoubleArray(FMemory)^[index];
  1038.     except
  1039.       InternalHandleException;
  1040.     end;
  1041.   end;
  1042. end;
  1043.  
  1044. function TDoubleArray.Add(Value: Double): Integer;
  1045. begin
  1046.   if (SortOrder = tsNone) then
  1047.     Result := FCount
  1048.   else
  1049.     if Find(Result, Value) then
  1050.       case Duplicates of
  1051.         dupIgnore : Exit;
  1052.         dupError  : ArrayDuplicateError;
  1053.       end;
  1054.   InsertAt(Result, Value);
  1055. end;
  1056.  
  1057. procedure TDoubleArray.Assign(Source: TPersistent);
  1058. var
  1059.   I: Integer;  
  1060. begin
  1061.   if (Source is TDoubleArray) then
  1062.   begin
  1063.     try
  1064.       Clear;
  1065.       for I := 0 to TBaseArray(Source).Count - 1 do
  1066.         Add(TDoubleArray(Source)[I]);
  1067.     finally
  1068.     end;
  1069.     Exit;
  1070.   end;
  1071.   inherited Assign(Source);
  1072. end;
  1073.  
  1074. function TDoubleArray.Find(var Index: Integer; Value: Double): Boolean;
  1075. var
  1076.   L, H, I, C: Integer;
  1077.   Value2: Double; 
  1078. begin
  1079.   Result := False;
  1080.   L := 0;
  1081.   H := Count - 1;
  1082.   while (L <= H) do
  1083.   begin
  1084.     I := (L + H) shr 1;
  1085.     Value2 := GetItem(I);
  1086.     C := FCompProc(Value2, Value);
  1087.     if (C < 0) then
  1088.       L := I + 1
  1089.     else
  1090.     begin
  1091.       H := I - 1;
  1092.       if (C = 0) then
  1093.       begin
  1094.         Result := True;
  1095.         if (Duplicates <> dupAccept) then
  1096.           L := I;
  1097.       end;
  1098.     end;
  1099.   end;
  1100.   Index := L;
  1101. end;
  1102.  
  1103. function TDoubleArray.IndexOf(var Item): Integer;
  1104. var
  1105.   item1: Double absolute Item;
  1106.   item2: Double; 
  1107. begin
  1108.   if (SortOrder = tsNone) then
  1109.   begin
  1110.     for Result := 0 to Count - 1 do
  1111.     begin
  1112.       item2 := GetItem(Result);
  1113.       if (FCompProc(item2, item1) = 0) then
  1114.         Exit;
  1115.     end;
  1116.     Result := -1;
  1117.   end
  1118.   else
  1119.     if not Find(Result, item1) then
  1120.       Result := -1;
  1121. end;
  1122.  
  1123.   { TCurrencyArray }
  1124.  
  1125. type
  1126.   TCArray = array[0..High(Integer) div Sizeof(Currency)-1] of Currency;
  1127.   PCurrencyArray = ^TCArray;
  1128.  
  1129. constructor TCurrencyArray.Create(itemcount, dummy: Integer);
  1130. begin
  1131.   inherited Create(itemcount, Sizeof(Currency));
  1132.   FCompProc := CmpCurrency;
  1133. end;
  1134.  
  1135. procedure TCurrencyArray.PutItem(index: Integer ; value: Currency);
  1136. begin
  1137.   if AutoSize and (FCount = FCapacity) then inherited Grow;
  1138.   try
  1139.     PCurrencyArray(FMemory)^[index] := value;
  1140.   except
  1141.     InternalHandleException;
  1142.   end;
  1143.   if (index > FCount-1) then Inc(FCount);
  1144. end;
  1145.  
  1146. function TCurrencyArray.GetItem(index: Integer): Currency;
  1147. begin
  1148.   Result := 0;
  1149.   if ValidIndex(index) then
  1150.   begin
  1151.     try
  1152.       Result := PCurrencyArray(FMemory)^[index];
  1153.     except
  1154.       InternalHandleException;
  1155.     end;
  1156.   end;
  1157. end;
  1158.  
  1159. function TCurrencyArray.Add(Value: Currency): Integer;
  1160. begin
  1161.   if (SortOrder = tsNone) then
  1162.     Result := FCount
  1163.   else
  1164.     if Find(Result, Value) then
  1165.       case Duplicates of
  1166.         dupIgnore : Exit;
  1167.         dupError  : ArrayDuplicateError;
  1168.       end;
  1169.   InsertAt(Result, Value);
  1170. end;
  1171.  
  1172. procedure TCurrencyArray.Assign(Source: TPersistent);
  1173. var
  1174.   I: Integer;
  1175. begin
  1176.   if (Source is TCurrencyArray) then
  1177.   begin
  1178.     try
  1179.       Clear;
  1180.       for I := 0 to TBaseArray(Source).Count - 1 do
  1181.         Add(TCurrencyArray(Source)[I]);
  1182.     finally
  1183.     end;
  1184.     Exit;
  1185.   end;
  1186.   inherited Assign(Source);
  1187. end;
  1188.  
  1189. function TCurrencyArray.Find(var Index: Integer; Value: Currency): Boolean;
  1190. var
  1191.   L, H, I, C: Integer;
  1192.   Value2: Currency;
  1193. begin
  1194.   Result := False;
  1195.   L := 0;
  1196.   H := Count - 1;
  1197.   while (L <= H) do
  1198.   begin
  1199.     I := (L + H) shr 1;
  1200.     Value2 := GetItem(I);
  1201.     C := FCompProc(Value2, Value);
  1202.     if (C < 0) then
  1203.       L := I + 1
  1204.     else
  1205.     begin
  1206.       H := I - 1;
  1207.       if (C = 0) then
  1208.       begin
  1209.         Result := True;
  1210.         if (Duplicates <> dupAccept) then
  1211.           L := I;
  1212.       end;
  1213.     end;
  1214.   end;
  1215.   Index := L;
  1216. end;
  1217.  
  1218. function TCurrencyArray.IndexOf(var Item): Integer;
  1219. var
  1220.   item1: Currency absolute Item;
  1221.   item2: Currency; 
  1222. begin
  1223.   if (SortOrder = tsNone) then
  1224.   begin
  1225.     for Result := 0 to Count - 1 do
  1226.     begin
  1227.       item2 := GetItem(Result);
  1228.       if (FCompProc(item2, item1) = 0) then
  1229.         Exit;
  1230.     end;
  1231.     Result := -1;
  1232.   end
  1233.   else
  1234.     if not Find(Result, item1) then
  1235.       Result := -1;
  1236. end;
  1237.  
  1238.   { TSmallIntArray }
  1239.  
  1240. type
  1241.   TSIArray = array[0..High(Integer) div Sizeof(SmallInt)-1] of SmallInt;
  1242.   PSmallIntArray = ^TSIArray;
  1243.  
  1244. constructor TSmallIntArray.Create(itemcount, dummy: Integer);
  1245. begin
  1246.   inherited Create(itemcount, Sizeof(SmallInt));
  1247.   FCompProc := CmpSmallInt;
  1248. end;
  1249.  
  1250. procedure TSmallIntArray.PutItem(index: Integer ; value: SmallInt);
  1251. begin
  1252.   if AutoSize and (FCount = FCapacity) then
  1253.     inherited Grow;
  1254.   try
  1255.     PSmallIntArray(FMemory)^[index] := value;
  1256.   except
  1257.     InternalHandleException;
  1258.   end;
  1259.   if index > FCount-1 then
  1260.     Inc(FCount);
  1261. end;
  1262.  
  1263. function  TSmallIntArray.GetItem(index: Integer): SmallInt;
  1264. begin
  1265.   Result := 0;
  1266.   if ValidIndex(index) then
  1267.   begin
  1268.     try
  1269.       Result := PSmallIntArray(FMemory)^[index];
  1270.     except
  1271.       InternalHandleException;
  1272.     end;
  1273.   end;
  1274. end;
  1275.  
  1276. function TSmallIntArray.Add(Value: SmallInt): Integer;
  1277. begin
  1278.   if (SortOrder = tsNone) then
  1279.     Result := FCount
  1280.   else
  1281.     if FindItem(Result, Value ) then
  1282.       case Duplicates of
  1283.         dupIgnore : Exit;
  1284.         dupError  : ArrayDuplicateError;
  1285.       end;
  1286.   InsertAt(Result, Value);
  1287. end;
  1288.  
  1289. procedure TSmallIntArray.Assign(Source: TPersistent);
  1290. var
  1291.   I: Integer; 
  1292. begin
  1293.   if (Source is TSmallIntArray) then
  1294.   begin
  1295.     try
  1296.       Clear;
  1297.       for I := 0 to TBaseArray(Source).Count - 1 do
  1298.         Add(TSmallIntArray(Source)[I]);
  1299.     finally
  1300.     end;
  1301.     Exit;
  1302.   end;
  1303.   inherited Assign(Source);
  1304. end;
  1305.  
  1306.   { TWordArray }
  1307.  
  1308. type
  1309.   TArrayWord = array[0..High(Integer) div Sizeof(Word)-1] of Word;
  1310.   PWordArray = ^TArrayWord;
  1311.  
  1312. constructor TWordArray.Create(itemcount, dummy: Integer);
  1313. begin
  1314.   inherited Create(itemcount, Sizeof(Word));
  1315.   FCompProc := CmpWord;
  1316. end;
  1317.  
  1318. procedure TWordArray.PutItem(index: Integer ; value: Word);
  1319. begin
  1320.   if AutoSize and (FCount = FCapacity) then
  1321.     inherited Grow;
  1322.   try
  1323.     PWordArray(FMemory)^[index] := value;
  1324.   except
  1325.     InternalHandleException;
  1326.   end;
  1327.   if (index > FCount-1) then
  1328.     Inc(FCount);
  1329. end;
  1330.  
  1331. function TWordArray.GetItem(index: Integer): Word;
  1332. begin
  1333.   Result := 0;
  1334.   if ValidIndex(index) then
  1335.   begin
  1336.     try
  1337.       Result := PWordArray(FMemory)^[index];
  1338.     except
  1339.       InternalHandleException;
  1340.     end;
  1341.   end;
  1342. end;
  1343.  
  1344. function TWordArray.Add(Value: Word): Integer;
  1345. begin
  1346.   if (SortOrder = tsNone) then
  1347.     Result := FCount
  1348.   else
  1349.     if Find(Result, Value) then
  1350.       case Duplicates of
  1351.         dupIgnore : Exit;
  1352.         dupError  : ArrayDuplicateError;
  1353.       end;
  1354.   InsertAt(Result, Value);
  1355. end;
  1356.  
  1357. procedure TWordArray.Assign(Source: TPersistent);
  1358. var
  1359.   I: Integer;
  1360. begin
  1361.   if (Source is TWordArray) then
  1362.   begin
  1363.     try
  1364.       Clear;
  1365.       for I := 0 to TBaseArray(Source).Count - 1 do
  1366.         Add(TWordArray(Source)[I]);
  1367.     finally
  1368.     end;
  1369.     Exit;
  1370.   end;
  1371.   inherited Assign(Source);
  1372. end;
  1373.  
  1374. function TWordArray.Find(var Index: Integer; Value: Word): Boolean;
  1375. var
  1376.   L, H, I, C: Integer;
  1377.   Value2: Word;
  1378. begin
  1379.   Result := False;
  1380.   L := 0;
  1381.   H := Count - 1;
  1382.   while (L <= H) do
  1383.   begin
  1384.     I := (L + H) shr 1;
  1385.     Value2 := GetItem(I);
  1386.     C := FCompProc(Value2, Value);
  1387.     if (C < 0) then
  1388.       L := I + 1
  1389.     else
  1390.     begin
  1391.       H := I - 1;
  1392.       if (C = 0) then
  1393.       begin
  1394.         Result := True;
  1395.         if (Duplicates <> dupAccept) then
  1396.           L := I;
  1397.       end;
  1398.     end;
  1399.   end;
  1400.   Index := L;
  1401. end;
  1402.  
  1403. function TWordArray.IndexOf(var Item): Integer;
  1404. var
  1405.   item1: Word absolute Item;
  1406.   item2: Word;
  1407. begin
  1408.   if (SortOrder = tsNone) then
  1409.   begin
  1410.     for Result := 0 to Count - 1 do
  1411.     begin
  1412.       item2 := GetItem(Result);
  1413.       if (FCompProc(item2, item1) = 0) then
  1414.         Exit;
  1415.     end;
  1416.     Result := -1;
  1417.   end
  1418.   else
  1419.     if not Find(Result, item1) then
  1420.       Result := -1;
  1421. end;
  1422.  
  1423.   { TPointerArray }
  1424.  
  1425. Type
  1426.   TPArray = Array [0..High(Integer) div Sizeof(Pointer)-1] Of Pointer;
  1427.   PPArray = ^TPArray;
  1428.  
  1429. constructor TPointerArray.Create(itemcount, dummy: Integer);
  1430. begin
  1431.   inherited Create(itemcount, Sizeof(Pointer));
  1432.   FFlags := [afAutoSize];
  1433. end;
  1434.  
  1435. procedure TPointerArray.CopyFrom(var Source; toIndex, numItems: Integer);
  1436. var
  1437.   i: Integer;
  1438.   p: PPArray;
  1439.   arr: TPArray absolute Source;
  1440. begin
  1441.   if (numItems = 0) then
  1442.     Exit;
  1443.   if ValidateBounds(toIndex, numItems) then
  1444.   begin
  1445.     InvalidateItems(toIndex, numItems);
  1446.     p := PPArray(FMemory);
  1447.     for i:= 0 to Pred(numItems) Do
  1448.       p^[toIndex+i] := CloneItem(arr[i]);
  1449.     FSortOrder := tsNone;
  1450.   end;
  1451. end;
  1452.  
  1453. procedure TPointerArray.CopyTo(var Dest; fromIndex, numItems: Integer);
  1454. var
  1455.   i: Integer;
  1456.   p: PPArray;
  1457.   arr: TPArray absolute Dest;
  1458. begin
  1459.   if (numItems = 0) then
  1460.     Exit;
  1461.   if ValidateBounds(fromIndex, numItems) then
  1462.   begin
  1463.     p := PPArray(FMemory);
  1464.     for i:= 0 to Pred(numItems) Do
  1465.       arr[i] := CloneItem(p^[fromIndex+i]);
  1466.   end;
  1467. end;
  1468.  
  1469. procedure TPointerArray.PutData(index: Integer ; value: Pointer);
  1470. begin
  1471.   if ValidIndex(index) then
  1472.   begin
  1473.     if (PPArray(FMemory)^[index] <> nil) and HasFlag(afOwnsData)then
  1474.       FreeItem(PPArray(FMemory)^[index]);
  1475.     PPArray(FMemory)^[index] := CloneItem(value);
  1476.     FSortOrder := tsNone;
  1477.   end;
  1478. end;
  1479.  
  1480. function TPointerArray.GetData(index: Integer): Pointer;
  1481. begin
  1482.   if ValidIndex(index) then
  1483.     Result := PPArray(FMemory)^[index]
  1484.   else
  1485.     Result := nil;
  1486. end;
  1487.  
  1488. procedure TPointerArray.FreeItem(item: Pointer);
  1489. begin
  1490.   { this is a nop for this class since we do not know what item points to }
  1491. end;
  1492.  
  1493. procedure TPointerArray.InvalidateItems(atIndex, numItems: Integer);
  1494. var
  1495.   n: Integer;
  1496.   p: Pointer;
  1497. begin
  1498.   if (numItems > 0) and HasFlag(afOwnsData) then
  1499.   begin
  1500.     if ValidateBounds(atIndex, numItems) then
  1501.     begin
  1502.       for n := atIndex to Pred(numItems+atIndex) Do
  1503.       begin
  1504.         p := AsPtr[n];
  1505.         if (p <> nil) then
  1506.         begin
  1507.           FreeItem(p);
  1508.           p := nil;
  1509.           PutItem(n, p);
  1510.         end;
  1511.       end;
  1512.     end;
  1513.   end;
  1514. end;
  1515.  
  1516. function TPointerArray.CloneItem(item: Pointer): Pointer;
  1517. begin
  1518.   Result := item;
  1519. end;
  1520.  
  1521.   { TStringArray }
  1522.  
  1523. type
  1524.   PStringItem = ^TStringItem;
  1525.   TStringItemList = array[0..MaxListSize] of TStringItem;
  1526.   PStringItemList = ^TStringItemList;
  1527.  
  1528. constructor TStringArray.Create(itemcount, dummy: Integer);
  1529. begin
  1530.   inherited Create(itemcount, Sizeof(TStringItem));
  1531.   FFlags := [afAutoSize];
  1532.   FCompProc := CmpString;   { Note: if the language driver is available then we use it for compares. }
  1533. end;
  1534.  
  1535. function TStringArray.Add(const S: String): Integer;
  1536. begin
  1537.   if (SortOrder = tsNone) then
  1538.     Result := FCount
  1539.   else
  1540.     if Find(S, Result) then
  1541.       case Duplicates of
  1542.         dupIgnore : Exit;
  1543.         dupError  : raise EArrayError.CreateRes(@SDuplicateString);
  1544.       end;
  1545.   InsertItem(Result, S);
  1546. end;
  1547.  
  1548. procedure TStringArray.Exchange(Index1, Index2: Integer);
  1549. begin
  1550.   if (Index1 < 0) or (Index1 >= FCount) or
  1551.   (Index2 < 0) or (Index2 >= FCount) then
  1552.     ArrayIndexError(Index1);    
  1553.   ExchangeItems(Index1, Index2);
  1554. end;
  1555.  
  1556. procedure TStringArray.ExchangeItems(Index1, Index2: Integer);
  1557. var
  1558.   Temp: Integer;
  1559.   Item1, Item2: PStringItem;  
  1560. begin
  1561.   Item1 := @PStringItemList(FMemory)^[Index1];
  1562.   Item2 := @PStringItemList(FMemory)^[Index2];
  1563.   Temp := Integer(Item1^.FString);
  1564.   Integer(Item1^.FString) := Integer(Item2^.FString);
  1565.   Integer(Item2^.FString) := Temp;
  1566.   Temp := Integer(Item1^.FObject);
  1567.   Integer(Item1^.FObject) := Integer(Item2^.FObject);
  1568.   Integer(Item2^.FObject) := Temp;
  1569. end;
  1570.  
  1571. function TStringArray.Find(S: string; var Index: Integer): Boolean;
  1572. var
  1573.   L, H, I: Integer;
  1574.   C: SmallInt;       { for compatability with the BDE LD }
  1575. begin
  1576.   Result := False;
  1577.   L := 0;
  1578.   H := Count - 1;
  1579.   while (L <= H) do
  1580.   begin
  1581.     I := (L + H) shr 1;
  1582.     C := SmallInt(FCompProc(PStringItemList(FMemory)^[I].FString, S));
  1583.     if (C < 0) then
  1584.       L := I + 1
  1585.     else
  1586.     begin
  1587.       H := I - 1;
  1588.       if (C = 0) then
  1589.       begin
  1590.         Result := True;
  1591.         if (Duplicates <> dupAccept) then
  1592.           L := I;
  1593.       end;
  1594.     end;
  1595.   end;
  1596.   Index := L;
  1597. end;
  1598.  
  1599. function TStringArray.GetObject(Index: Integer): TObject;
  1600. begin
  1601.   Result := nil;
  1602.   if ValidIndex(Index) then
  1603.     Result := PStringItemList(FMemory)^[Index].FObject;
  1604. end;
  1605.  
  1606. procedure TStringArray.Grow;
  1607. var
  1608.   Delta: Integer;
  1609. begin
  1610.   if (FCapacity > 64) then
  1611.     Delta := FCapacity div 4
  1612.   else if (FCapacity > 8) then
  1613.     Delta := 16
  1614.   else
  1615.     Delta := 4;
  1616.   inherited SetCapacity(FCapacity + Delta);
  1617. end;
  1618.  
  1619. function TStringArray.IndexOf(var Item): Integer;
  1620. var
  1621.   S1: string;
  1622.   S2: string absolute Item;
  1623. begin
  1624.   if (SortOrder = tsNone) then
  1625.   begin
  1626.     for Result := 0 to Count - 1 do
  1627.     begin
  1628.       S1 := GetString(Result);
  1629.       if (SmallInt(FCompProc(S1, S2)) = 0) then
  1630.         Exit;
  1631.     end;
  1632.     Result := -1;
  1633.   end
  1634.   else
  1635.     if not Find(S2, Result) then
  1636.       Result := -1;
  1637. end;
  1638.  
  1639. procedure TStringArray.Insert(Index: Integer; var Value);
  1640. var
  1641.   S: string;
  1642. begin
  1643.   S := Variant(Value);
  1644.   if (SortOrder <> tsNone) then
  1645.     raise EArrayError.CreateRes(@SSortedListError);
  1646.   if (Index < 0) or (Index > FCount) then
  1647.     ArrayIndexError(Index);
  1648.   InsertItem(Index, S);
  1649. end;
  1650.  
  1651. procedure TStringArray.InsertItem(Index: Integer; const S: string);
  1652. begin
  1653.   if (FCount = FCapacity) then
  1654.     Grow;
  1655.   if (Index < FCount) then
  1656.   begin
  1657.     try
  1658.       System.Move(PStringItemList(FMemory)^[Index], PStringItemList(FMemory)^[Index + 1],
  1659.         (FCount - Index) * SizeOf(TStringItem));
  1660.     except
  1661.       InternalHandleException;
  1662.     end;
  1663.   end;
  1664.   try
  1665.     PStringItemList(FMemory)^[Index].FObject := nil;
  1666.     Pointer(PStringItemList(FMemory)^[Index].FString) := nil;
  1667.     PStringItemList(FMemory)^[Index].FString := S;
  1668.   except
  1669.     InternalHandleException;
  1670.   end;
  1671.   Inc(FCount);
  1672. end;
  1673.  
  1674. procedure TStringArray.PutString(Index: Integer; const S: string);
  1675. begin
  1676.   { Sorted items must be added }
  1677.   if (SortOrder <> tsNone) then
  1678.     raise EArrayError.CreateRes(@SSortedListError);
  1679.   if ValidIndex(Index) then
  1680.   begin
  1681.     try
  1682.       PStringItemList(FMemory)^[Index].FString := S;
  1683.     except
  1684.       InternalHandleException;
  1685.     end;
  1686.   end;
  1687. end;
  1688.  
  1689. function TStringArray.GetString(Index: Integer): string;
  1690. begin
  1691.  {$IFOPT R+}
  1692.   if ValidIndex(Index) then
  1693.  {$ENDIF}
  1694.   begin
  1695.     try
  1696.       Result := PStringItemList(FMemory)^[Index].FString;
  1697.     except
  1698.       Clear;
  1699.       raise;
  1700.     end;
  1701.   end;
  1702. end;
  1703.  
  1704. procedure TStringArray.PutObject(Index: Integer; AObject: TObject);
  1705. begin
  1706.   if ValidIndex(Index) then
  1707.     PStringItemList(FMemory)^[Index].FObject := AObject;
  1708. end;
  1709.  
  1710. procedure TStringArray.QuickSort(L, R: Integer);
  1711. var
  1712.   I, J: Integer;
  1713.   P: string;
  1714. begin
  1715.   repeat
  1716.     I := L;
  1717.     J := R;
  1718.     P := PStringItemList(FMemory)^[(L + R) shr 1].FString;
  1719.     repeat
  1720.       while (SmallInt(FCompProc(PStringItemList(FMemory)^[I].FString, P)) < 0) do
  1721.         Inc(I);
  1722.       while (SmallInt(FCompProc(PStringItemList(FMemory)^[J].FString, P)) > 0) do
  1723.         Dec(J);
  1724.       if (I <= J) then
  1725.       begin
  1726.         ExchangeItems(I, J);
  1727.         Inc(I);
  1728.         Dec(J);
  1729.       end;
  1730.     until (I > J);
  1731.     if (L < J) then
  1732.       QuickSort(L, J);
  1733.     L := I;
  1734.   until (I >= R);
  1735. end;
  1736.  
  1737. procedure TStringArray.Sort(Compare: TCompareProc);
  1738. begin
  1739.   if (SortOrder <> tsNone) and (Count > 1) then
  1740.     QuickSort(0, Count - 1);
  1741. end;
  1742.  
  1743. procedure TStringArray.AddStrings(Strings: TStringArray);
  1744. var
  1745.   I: Integer;
  1746. begin
  1747.   try
  1748.     for I := 0 to Strings.Count - 1 do
  1749.       Add(Strings.Strings[I]);
  1750.   finally
  1751.   end;
  1752. end;
  1753.  
  1754. procedure TStringArray.Assign(Source: TPersistent);
  1755. begin
  1756.   if (Source is TStringArray) then
  1757.   begin
  1758.     try
  1759.       Clear;
  1760.       AddStrings(TStringArray(Source));
  1761.     finally
  1762.     end;
  1763.     Exit;
  1764.   end;
  1765.   inherited Assign(Source);
  1766. end;
  1767.  
  1768. procedure TStringArray.InvalidateItems(atIndex, numItems: Integer);
  1769. begin
  1770.   Finalize(PStringItemList(FMemory)^[atIndex], numItems);
  1771. end;
  1772.  
  1773.   { TCustomArray }
  1774.  
  1775. function VariantTypeToName(vType: Integer): string;
  1776. begin
  1777.   case vType of
  1778.     varEmpty    : Result := 'Empty';     { Do not localize }
  1779.     varNull     : Result := 'Null';      { Do not localize }
  1780.     varOleStr   : Result := 'OleStr';    { Do not localize }
  1781.     varDispatch : Result := 'Dispatch';  { Do not localize }
  1782.     varError    : Result := 'Error';     { Do not localize }
  1783.     varVariant  : Result := 'Variant';   { Do not localize }
  1784.     varByte     : Result := 'Byte';      { Do not localize }
  1785.     varTypeMask : Result := 'TypeMask';  { Do not localize }
  1786.     varArray    : Result := 'Array';     { Do not localize }
  1787.     varByRef    : Result := 'ByRef';     { Do not localize }
  1788.     else
  1789.       Result := 'Unknown';            { Do not localize }
  1790.   end;
  1791. end;
  1792.  
  1793. constructor TCustomArray.Create(Items: Integer; VarType: Integer);
  1794. begin
  1795.   FDataType       := VarType;
  1796.   FBlankDateVal   := -650000;  { Satisfies Variants, Lowest TDateTime is actually -693593 }
  1797.   FBlankStringVal := '0';
  1798.   FBlankBoolVal   := 2;
  1799.   FBlankCount     := 0;
  1800.  
  1801.   case VarType of
  1802.     varSmallint: FArray := TSmallIntArray.Create(Items, 0);
  1803.     varInteger:  FArray := TIntArray.Create(Items, 0);
  1804.     varDate,
  1805.     varDouble:   FArray := TDoubleArray.Create(Items, 0);
  1806.     varBoolean:  FArray := TWordArray.Create(Items, 0);
  1807.     varString:   FArray := TStringArray.Create(Items, 0);
  1808.     varSingle:   FArray := TSingleArray.Create(Items, 0);
  1809.     varCurrency: FArray := TCurrencyArray.Create(Items, 0);
  1810.     else
  1811.       UnsupportedTypeError(FDataType);
  1812.   end;
  1813. end;
  1814.  
  1815. destructor TCustomArray.Destroy;
  1816. begin
  1817.   if Assigned(FArray) then
  1818.   begin
  1819.     TBaseArray(FArray).Destroy;
  1820.     FArray := nil;
  1821.   end;
  1822.   FDataType := 0;
  1823.   inherited Destroy;
  1824. end;
  1825.  
  1826. procedure TCustomArray.UnsupportedTypeError(vType: Integer);
  1827. var
  1828.   sDataType: string;
  1829. begin
  1830.   sDataType := VariantTypeToName(vType);
  1831.   raise EUnsupportedTypeError.CreateResFmt(@sUnsupportedDataType, [sDataType]);
  1832. end;
  1833.  
  1834. function TCustomArray.GetMemberCount: Integer;
  1835. begin
  1836.   Result :=  TBaseArray(FArray).Count;
  1837. end;
  1838.  
  1839. function TCustomArray.GetItem(Index: Integer): Variant;
  1840. var
  1841.   V: Variant;  
  1842. begin
  1843.   case FDataType of
  1844.     varSmallint: Result := TSmallIntArray(FArray)[Index];
  1845.     varDate:
  1846.     begin
  1847.       V := TDoubleArray(FArray)[Index];
  1848.       Result := VarAsType(V, varDate)
  1849.     end;
  1850.  
  1851.     varInteger:  Result := TIntArray(FArray)[Index];
  1852.     varDouble:   Result := TDoubleArray(FArray)[Index];
  1853.     varBoolean:  Result := TWordArray(FArray)[Index];
  1854.     varString:   Result := TStringArray(FArray).GetString(Index);
  1855.     varSingle:   Result := TSingleArray(FArray)[Index];
  1856.     varCurrency: Result := TCurrencyArray(FArray)[Index];
  1857.     else
  1858.       UnsupportedTypeError(FDataType);
  1859.   end;
  1860. end;
  1861.  
  1862. function TCustomArray.GetDouble(Index: Integer): Double;
  1863. begin
  1864.   Result := TDoubleArray(FArray).GetItem(index);
  1865. end;
  1866.  
  1867. function TCustomArray.GetCurrency(Index: Integer): Currency;
  1868. begin
  1869.   Result := TCurrencyArray(FArray).GetItem(index);
  1870. end;
  1871.  
  1872. function TCustomArray.GetInteger(Index: Integer): Integer;
  1873. begin
  1874.   Result := TIntArray(FArray).GetItem(index);
  1875. end;
  1876.  
  1877. function TCustomArray.IsBlank(Index: Integer): Boolean;
  1878. begin
  1879.   case FDataType of
  1880.     varDate:     Result := (TDoubleArray(FArray)[Index] = BlankDateVal);
  1881.     varString:   Result := (TStringArray(FArray).GetString(Index) = BlankStringVal);
  1882.     varBoolean:  Result := (TWordArray(FArray)[Index] = BlankBoolVal);
  1883.     else
  1884.       Result := False;
  1885.   end;
  1886. end;
  1887.  
  1888. procedure TCustomArray.SetItem(Index: Integer; Value: Variant);
  1889. var
  1890.   VarData: TVarData;
  1891. begin
  1892.   VarData := TVarData(Value);
  1893.   { Handle blank values and misc conversion problems }
  1894.   if (FDataType <> VarData.vType) then
  1895.   begin
  1896.      case VarData.vType of
  1897.        varEmpty,
  1898.        varNull :       begin         Inc(FBlankCount);         case FDataType of           varDate    : Value := VarAsType(BlankDateVal, varDouble);           varString  : Value := VarAsType(BlankStringVal, varString);           varBoolean : Value := VarAsType(BlankBoolVal, varSmallInt);           else             Value := VarAsType(0, FDataType);         end;       end;       varDouble : if (FDataType = varCurrency) then                     Value := VarAsType(Value, varCurrency);     end;  end;  case FDataType of
  1899.     varSmallint: TSmallIntArray(FArray)[Index] := Value.VSmallInt;
  1900.     varDate:     TDoubleArray(FArray)[Index] := TVarData(Value).VDouble;
  1901.     varInteger:  TIntArray(FArray)[Index] := Value;
  1902.     varDouble:   TDoubleArray(FArray)[Index] := Value;
  1903.     varBoolean:  TWordArray(FArray)[Index] := Value;
  1904.     varString:   TStringArray(FArray).Insert(Index, Value);
  1905.     varSingle:   TSingleArray(FArray)[Index] := Value;
  1906.     varCurrency: TCurrencyArray(FArray)[Index] := Value;
  1907.     else
  1908.       UnsupportedTypeError(FDataType);
  1909.   end;
  1910. end;
  1911.  
  1912. function TCustomArray.IndexOf(Value: Variant): Integer;
  1913. var
  1914.   vConv: Variant;
  1915.   strVal: String;
  1916.   iVal: Integer;
  1917.   siVal: SmallInt;
  1918.   dVal: Double;
  1919.   sgVal: Single;
  1920.   cVal: Currency;
  1921.   bVal: Word;  
  1922. begin
  1923.   { This should raise an array index exception if below fails }
  1924.   Result := -1;
  1925.   case FDataType of
  1926.     varSmallint:
  1927.     begin
  1928.       VarCast(vConv, Value, varSmallInt);
  1929.       siVal := SmallInt(TVarData(vConv).VSmallint);
  1930.       Result := TBaseArray(FArray).IndexOf(siVal);
  1931.     end;
  1932.     varDate,
  1933.     varDouble:
  1934.     begin
  1935.       VarCast(vConv, Value, varDouble);
  1936.       dVal := Double(TVarData(vConv).VDouble);
  1937.       Result := TBaseArray(FArray).IndexOf(dVal);
  1938.     end;
  1939.     varInteger:
  1940.     begin
  1941.       VarCast(vConv, Value, varInteger);
  1942.       iVal := Integer(TVarData(vConv).VInteger);
  1943.       Result := TBaseArray(FArray).IndexOf(iVal);
  1944.     end;
  1945.     varString:
  1946.     begin
  1947.       VarCast(vConv, Value, varString);
  1948.       strVal := String(TVarData(vConv).VString);
  1949.       Result := TStringArray(FArray).IndexOf(strVal)
  1950.     end;
  1951.     varSingle:
  1952.     begin
  1953.       VarCast(vConv, Value, varSingle);
  1954.       sgVal := Single(TVarData(vConv).VSingle);
  1955.       Result := TBaseArray(FArray).IndexOf(sgVal);
  1956.     end;
  1957.     varCurrency:
  1958.     begin
  1959.       VarCast(vConv, Value, varCurrency);
  1960.       cVal := Currency(TVarData(vConv).VCurrency);
  1961.       Result := TCurrencyArray(FArray).IndexOf(cVal);
  1962.     end;
  1963.     varBoolean:
  1964.     begin
  1965.       if (Value = BlankBoolVal) then
  1966.       begin
  1967.         bVal := BlankBoolVal;
  1968.       end
  1969.       else
  1970.       begin
  1971.         VarCast(vConv, Value, varBoolean);
  1972.         bVal := Word(TVarData(vConv).VBoolean);
  1973.       end;
  1974.       Result := TWordArray(FArray).IndexOf(bVal);
  1975.     end;
  1976.     else
  1977.       UnsupportedTypeError(FDataType);
  1978.   end;
  1979. end;
  1980.  
  1981. procedure TCustomArray.Assign(Value: TCustomArray; bSorted, bUnique: Boolean);
  1982. begin
  1983.   if bSorted then
  1984.     TBaseArray(FArray).SortOrder := tsDescending;
  1985.   if bUnique then
  1986.     TBaseArray(FArray).Duplicates := dupIgnore;
  1987.   case FDataType of
  1988.     varString   : TStringArray(FArray).Assign(TStringArray(Value.FArray));
  1989.     varSmallint : TSmallIntArray(FArray).Assign(TSmallIntArray(Value.FArray));
  1990.     varInteger  : TIntArray(FArray).Assign(TIntArray(Value.FArray));
  1991.     varDate,
  1992.     varDouble   : TDoubleArray(FArray).Assign(TDoubleArray(Value.FArray));
  1993.     varBoolean  : TWordArray(FArray).Assign(TWordArray(Value.FArray));
  1994.     varSingle   : TSingleArray(FArray).Assign(TSingleArray(Value.FArray));
  1995.     varCurrency : TCurrencyArray(FArray).Assign(TCurrencyArray(Value.FArray));
  1996.     else
  1997.       UnsupportedTypeError(FDataType);
  1998.   end;
  1999. end;
  2000.  
  2001. function TCustomArray.Add(Value: Variant): Integer;
  2002. var
  2003.   VarData: TVarData; 
  2004. begin
  2005.   VarData := TVarData(Value);
  2006.   Result := -1;  { Error }
  2007.   { Handle blank values and misc conversion problems }
  2008.   if (FDataType <> VarData.vType) then
  2009.   begin
  2010.      case VarData.vType of
  2011.        varEmpty,
  2012.        varNull :       begin         Inc(FBlankCount);         case FDataType of           varDate    : Value := VarAsType(BlankDateVal, varDouble);           varString  : Value := VarAsType(BlankStringVal, varString);           varBoolean : Value := VarAsType(BlankBoolVal, varSmallInt);           else             Value := VarAsType(0, FDataType);         end;       end;       varDouble : if (FDataType = varCurrency) then                     Value := VarAsType(Value, varCurrency);     end;  end;  case FDataType of
  2013.     varString   : Result := TStringArray(FArray).Add(VarToStr(Value));
  2014.     varSmallint : Result := TSmallIntArray(FArray).Add(TVarData(Value).VSmallint);
  2015.     varInteger  : Result := TIntArray(FArray).Add(TVarData(Value).VInteger);
  2016.     varDate,
  2017.     varDouble   : Result := TDoubleArray(FArray).Add(TVarData(Value).VDouble);
  2018.     varBoolean  : Result := TWordArray(FArray).Add(Word(TVarData(Value).VBoolean));
  2019.     varSingle   : Result := TSingleArray(FArray).Add(TVarData(Value).VSingle);
  2020.     varCurrency : Result := TCurrencyArray(FArray).Add(TVarData(Value).VCurrency);
  2021.     else
  2022.       UnsupportedTypeError(FDataType);
  2023.   end;
  2024. end;
  2025.  
  2026. function TCustomArray.GetCompProc: TCompareProc;
  2027. begin
  2028.   Result := TBaseArray(FArray).CompareProc;
  2029. end;
  2030.  
  2031. procedure TCustomArray.SetCompProc(Proc: TCompareProc);
  2032. begin
  2033.   TBaseArray(FArray).CompareProc := Proc;
  2034. end;
  2035.  
  2036. procedure TCustomArray.SetSize(size: Integer);
  2037. begin
  2038.   TBaseArray(FArray).SetCapacity(size);
  2039. end;
  2040.  
  2041. function TCustomArray.MemoryUsage: Integer;
  2042. begin
  2043.   Result := (TBaseArray(FArray).Capacity * TBaseArray(FArray).ItemSize);
  2044. end;
  2045.  
  2046. function  TCustomArray.GetSort: Boolean;
  2047. begin
  2048.   Result := (TBaseArray(FArray).SortOrder) <> tsNone;
  2049. end;
  2050.  
  2051. procedure TCustomArray.SetSort(Value: Boolean);
  2052. begin
  2053.   TBaseArray(FArray).SortOrder := tsDescending;
  2054. end;
  2055.  
  2056. function  TCustomArray.GetDups: TDuplicates;
  2057. begin
  2058.   Result := TBaseArray(FArray).Duplicates;
  2059. end;
  2060.  
  2061. procedure TCustomArray.SetDups(Value: TDuplicates);
  2062. begin
  2063.   TBaseArray(FArray).Duplicates := Value;
  2064. end;
  2065.  
  2066. function TCustomArray.ConvertVar(Value: Variant): Variant;
  2067. begin
  2068.   case TVarData(Value).vType of
  2069.     varNull:
  2070.     begin
  2071.       case DataType of
  2072.         varDate     : Result := VarAsType(BlankDateVal, DataType);
  2073.         varString   : Result := VarAsType(BlankStringVal, DataType);
  2074.         varBoolean  : Result := VarAsType(BlankBoolVal, DataType);
  2075.         else
  2076.           Result := VarAsType(0, DataType);
  2077.       end;
  2078.     end;
  2079.     varSmallint,
  2080.     varInteger,
  2081.     varDate,
  2082.     varDouble,
  2083.     varBoolean,
  2084.     varString,
  2085.     varSingle,
  2086.     varCurrency: Result := VarAsType(Value, DataType);
  2087.     else
  2088.       UnsupportedTypeError(TVarData(Value).vType);
  2089.   end;
  2090. end;
  2091.  
  2092.   { TTwoDimArray }
  2093.  
  2094. constructor TTwoDimArray.Create;
  2095. begin
  2096.   inherited Create;
  2097.   FRows    := 0;
  2098.   FColumns := 0;
  2099.   mtxElements := nil;
  2100. end;
  2101.  
  2102. destructor TTwoDimArray.Destroy;
  2103. var
  2104.   col: TMatrixNDX;  
  2105. begin
  2106.   if Assigned(mtxElements) then
  2107.   begin
  2108.     try
  2109.       for col := FColumns-1 downto 0 do
  2110.       begin
  2111.         dec(FMemAllocated, mtxElements^[col].FCapacity);
  2112.         mtxElements^[col].Free;
  2113.         mtxElements^[col] := nil;
  2114.       end;
  2115.     finally
  2116.       FreeMem(mtxElements, FMemAllocated);
  2117.     end;
  2118.   end;
  2119.   inherited Destroy;
  2120. end;
  2121.  
  2122. procedure TTwoDimArray.SetSize(NumRows : TDynArrayNDX; NumColumns : TMatrixNDX);
  2123. var
  2124.   col: TMatrixNDX;  
  2125. begin
  2126.   FRows := NumRows;
  2127.   FColumns := NumColumns;
  2128.   FMemAllocated := FColumns*sizeof(TSmallIntArray);
  2129.   if ((FMemAllocated + TotalAllocatedMemory) > AvailableMemory) then
  2130.     LowCapacityError;
  2131.   GetMem(mtxElements, FColumns*sizeof(TSmallIntArray));
  2132.   Inc(TotalAllocatedMemory, FMemAllocated);
  2133.   { acquire memory for each column of the matrix }
  2134.   for col := 0 to FColumns-1 do
  2135.   begin
  2136.     mtxElements^[col] := TSmallIntArray.Create(FRows, 0);
  2137.     inc(FMemAllocated, mtxElements^[col].FCapacity);
  2138.   end;
  2139. end;
  2140.  
  2141. function TTwoDimArray.GetElement(row : TDynArrayNDX; column : TMatrixNDX) : SmallInt;
  2142. begin
  2143.   if (row > FRows) then
  2144.     raise EDynArrayRangeError.CreateResFMT(@sRowOutOfRange, [row]);
  2145.   if (column > FColumns) then
  2146.     raise EDynArrayRangeError.CreateResFMT(@sColOutOfRange, [column]);
  2147.   Result := mtxElements^[column].Items[row];
  2148. end;
  2149.  
  2150. procedure TTwoDimArray.SetElement(row : TDynArrayNDX; column : TMatrixNDX; const NewValue : SmallInt);
  2151. begin
  2152.   if (row > FRows) then
  2153.     raise EDynArrayRangeError.CreateResFMT(@sRowOutOfRange, [row]);
  2154.   if (column > FColumns) then
  2155.     raise EDynArrayRangeError.CreateResFMT(@sColOutOfRange, [column]);
  2156.   mtxElements^[column].Items[row] := NewValue;
  2157. end;
  2158.  
  2159.   { TIndexArray }
  2160.  
  2161. constructor TIndexArray.Create;
  2162. begin
  2163.   inherited Create;
  2164.   FCapacity := 0;
  2165.   FCount := 0;
  2166.   FMemAllocated := 0;
  2167.   FAutosize := False;
  2168.   idxElements := nil;
  2169. end;
  2170.  
  2171. destructor TIndexArray.Destroy;
  2172. var
  2173.   Idx: TIndexNDX;  
  2174. begin
  2175.   if Assigned(idxElements) then
  2176.   begin
  2177.     try
  2178.       if (FCount > 0) then
  2179.       begin
  2180.         for Idx := FCount-1 downto 0 do
  2181.         begin
  2182.           dec(FMemAllocated, idxElements^[Idx].FCapacity);
  2183.           idxElements^[Idx].Free;
  2184.           idxElements^[Idx] := nil;
  2185.         end;
  2186.       end;
  2187.     finally
  2188.       FreeMem(idxElements, FMemAllocated);
  2189.     end;
  2190.   end;
  2191.   inherited Destroy;
  2192. end;
  2193.  
  2194. procedure TIndexArray.SetSize(Elements: TIndexNDX);
  2195. begin
  2196.   FCapacity := Elements;
  2197.   FMemAllocated := FCapacity*sizeof(TSmallIntArray);
  2198.   if ((FMemAllocated + TotalAllocatedMemory) > AvailableMemory) then
  2199.     LowCapacityError;
  2200.   GetMem(idxElements, FCapacity*sizeof(TSmallIntArray));
  2201.   Inc(TotalAllocatedMemory, FMemAllocated);
  2202. end;
  2203.  
  2204. procedure TIndexArray.expand;
  2205. var
  2206.   Delta, NewCapacity, OldCapacity: Integer;  
  2207. begin
  2208.   if (FCapacity > 64) then
  2209.     Delta := FCapacity div 4
  2210.   else if (FCapacity > 8) then
  2211.     Delta := 16
  2212.   else
  2213.     Delta := 4;
  2214.   NewCapacity := FCapacity + Delta;
  2215.   OldCapacity := FCapacity;
  2216.   if (NewCapacity <> FCapacity) then
  2217.   begin
  2218.     try
  2219.       FMemAllocated := NewCapacity*sizeof(TSmallIntArray);
  2220.       if CheckLowCapacity(OldCapacity*sizeof(TSmallIntArray), newCapacity*sizeof(TSmallIntArray)) then
  2221.         LowCapacityError;
  2222.       ReallocMem(idxElements, NewCapacity*sizeof(TSmallIntArray));
  2223.       Inc(TotalAllocatedMemory, NewCapacity*sizeof(TSmallIntArray));
  2224.     except
  2225.       FreeMem(idxElements);
  2226.       raise;
  2227.     end;
  2228.     FCapacity := NewCapacity;
  2229.   end;
  2230. end;
  2231.  
  2232. function TIndexArray.GetElement(Element : TIndexNDX) : TSmallIntArray;
  2233. begin
  2234.   if (Element > FCapacity) then
  2235.     ArrayIndexError(Element);
  2236.   Result := idxElements^[Element];
  2237. end;
  2238.  
  2239. procedure TIndexArray.SetElement(Element : TIndexNDX; const NewValue: TSmallIntArray);
  2240. begin
  2241.   if AutoSize and (FCount = FCapacity) then
  2242.     Expand;
  2243.   Assert(FCapacity >= FCount, Format('FCount = %d FCapacity = %d', [FCount, FCapacity]));
  2244.   if (Element > FCapacity) then
  2245.     ArrayIndexError(Element);
  2246.   idxElements^[Element] := NewValue;
  2247.   inc(FMemAllocated, NewValue.FCapacity);
  2248.   if (Element > FCount-1) then
  2249.     Inc(FCount);
  2250. end;
  2251.  
  2252. function TIndexArray.Add(const NewValue: TSmallIntArray): Integer;
  2253. begin
  2254.   if AutoSize and (FCount = FCapacity) then
  2255.     Expand;
  2256.   Assert(FCapacity >= FCount, Format('FCount = %d FCapacity = %d', [FCount, FCapacity]));
  2257.   idxElements^[FCount] := NewValue;
  2258.   inc(FMemAllocated, NewValue.FCapacity);
  2259.   Inc(FCount);
  2260.   Result := FCount;
  2261. end;
  2262.  
  2263.   { TThreadCustomArray }
  2264.  
  2265. constructor TThreadCustomArray.Create(Items: Integer; VarType: Integer);
  2266. begin
  2267.   inherited Create;
  2268.   InitializeCriticalSection(FLock);
  2269.   FCustomArray := TCustomArray.Create(Items, VarType);
  2270. end;
  2271.  
  2272. destructor TThreadCustomArray.Destroy;
  2273. begin
  2274.   LockArray;    // Make sure nobody else is inside the list.
  2275.   try
  2276.     FCustomArray.Free;
  2277.     inherited Destroy;
  2278.   finally
  2279.     UnlockArray;
  2280.     DeleteCriticalSection(FLock);
  2281.   end;
  2282. end;
  2283.  
  2284. function TThreadCustomArray.Add(Item: Variant): Integer;
  2285. begin
  2286.   LockArray;
  2287.   Result := -1;
  2288.   try
  2289.     if (FCustomArray.IndexOf(Item) = -1) then
  2290.       Result := FCustomArray.Add(Item);
  2291.   finally
  2292.     UnlockArray;
  2293.   end;
  2294. end;
  2295.  
  2296. function TThreadCustomArray.LockArray: TCustomArray;
  2297. begin
  2298.   EnterCriticalSection(FLock);
  2299.   Result := FCustomArray;
  2300. end;
  2301.  
  2302. function TThreadCustomArray.GetItem(Index: Integer): Variant;
  2303. begin
  2304.   LockArray;
  2305.   try
  2306.     Result := FCustomArray.GetItem(Index);
  2307.   finally
  2308.     UnlockArray;
  2309.   end;
  2310. end;
  2311.  
  2312. function TThreadCustomArray.MemoryUsage: Integer;
  2313. begin
  2314.   LockArray;
  2315.   try
  2316.     Result := FCustomArray.MemoryUsage;
  2317.   finally
  2318.     UnlockArray;
  2319.   end;    
  2320. end;
  2321.  
  2322. procedure TThreadCustomArray.UnlockArray;
  2323. begin
  2324.   LeaveCriticalSection(FLock);
  2325. end;
  2326.  
  2327.  
  2328. initialization
  2329.   { determine available memory }
  2330.   AvailableMemory := GetAvailableMem;
  2331.   TotalAllocatedMemory := 0;
  2332.  
  2333. end.
  2334.