stlarr.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* SysTools: StLArr.pas 4.03                             *}
{*********************************************************}
{* SysTools: Large array classes                         *}
{*********************************************************}

{$I StDefine.inc}

{Notes:
  - requires a 386 or better processor, even for 16-bit Delphi apps

  - uses the value in the SYSTEM variable HeapAllocFlags when allocating
    memory for the array.

  - changing the size of an array allocates a new array, transfers the
    old data, and then frees the original array.

  - arrays are always indexed from 0 to Count-1.

  - after creating a descendant that knows the type of each element, an
    indexed default property can be used to access array elements in a
    convenient fashion, e.g., A[100] := 6.0;

  - the Get and Put methods don't perform range checking.

  - for 32-bit matrix, Rows*Cols cannot exceed 2**32.
}

unit StLArr;

interface

uses
  Windows,
  Classes, StConst, StBase;

type
  TStLArray = class(TStContainer)
  {.Z+}
  protected
    {property instance variables}
    FElSize     : Integer;     {Size of each array element}            
    FElStorable : boolean;     {True if elements can be stored directly}

    {private instance variables}
    laData     : Pointer;    {Pointer to data block}

    {undocumented protected methods}
    procedure ForEachUntypedVar(Action : TIterateUntypedFunc;
                                OtherData : pointer);
      override;
    procedure GetArraySizes(var RowCount, ColCount, ElSize : Cardinal);
      override;
    procedure SetArraySizes(RowCount, ColCount, ElSize : Cardinal);
      override;
    function StoresUntypedVars : boolean;
      override;
    procedure laSetCount(Elements : LongInt);

  {.Z-}
  public
    constructor Create(Elements : LongInt; ElementSize : Cardinal);
      {-Initialize a large 1D array}
    destructor Destroy; override;
      {-Free a large 1D array}

    procedure LoadFromStream(S : TStream); override;
      {-Load a collection's data from a stream}
    procedure StoreToStream(S : TStream); override;
      {-Write a collection and its data to a stream}

    procedure Assign(Source: TPersistent); override;
      {-Assign another container's contents to this one}
    procedure Clear; override;
      {-Fill the array with zeros}

    procedure Fill(const Value);
      {-Fill array with specified value}

    procedure Put(El : LongInt; const Value);
      {-Set an element}
    procedure Get(El : LongInt; var Value);
      {-Return an element}

    procedure Exchange(El1, El2 : LongInt);
      {-Exchange the specified elements}
    procedure Sort(Compare : TUntypedCompareFunc);
      {-Sort the array using the given comparison function}

    property Count : LongInt
      {-Read or write the number of elements in the array}
      read FCount
      write laSetCount;

    property ElementSize : Integer                                     
      read FElSize;

    property ElementsStorable : boolean
      {-True if elements can be written directly to (or read from) disk}
      read FElStorable write FElStorable;
  end;

type
  TStLMatrix = class(TStContainer)
  {.Z+}
  protected
    {property instance variables}
    FElSize   : Integer;    {Size of each array element}               
    FCols     : Cardinal;   {Number of columns}
    FRows     : Cardinal;   {Number of rows}
    FElStorable : boolean;     {True if elements can be stored directly}

    {private instance variables}
    lmData     : Pointer;    {Pointer to data block}
    lmRowSize  : LongInt;    {Number of bytes in a row}

    {undocumented protected methods}
    procedure ForEachUntypedVar(Action : TIterateUntypedFunc; OtherData : pointer);
      override;
    procedure GetArraySizes(var RowCount, ColCount, ElSize : Cardinal);
      override;
    procedure SetArraySizes(RowCount, ColCount, ElSize : Cardinal);
      override;
    function StoresUntypedVars : boolean;
      override;
    procedure lmSetRows(Rows : Cardinal);
    procedure lmSetCols(Cols : Cardinal);

  {.Z-}
  public
    constructor Create(Rows, Cols, ElementSize : Cardinal);
      {-Initialize a large 2D matrix}
    destructor Destroy; override;
      {-Free a large 2D matrix}

    procedure LoadFromStream(S : TStream); override;
      {-Load a collection's data from a stream}
    procedure StoreToStream(S : TStream); override;
      {-Write a collection and its data to a stream}

    procedure Assign(Source: TPersistent); override;
      {-Assign another container's contents to this one}
    procedure Clear; override;
      {-Fill the matrix with zeros}

    procedure Fill(const Value);
      {-Fill matrix with specified value}

    procedure Put(Row, Col : Cardinal; const Value);
      {-Set an element}
    procedure Get(Row, Col : Cardinal; var Value);
      {-Return an element}

    procedure PutRow(Row : Cardinal; const RowValue);
      {-Set an entire row}
    procedure GetRow(Row : Cardinal; var RowValue);
      {-Return an entire row}

    procedure ExchangeRows(Row1, Row2 : Cardinal);
      {-Exchange the specified rows}
    procedure SortRows(KeyCol : Cardinal; Compare : TUntypedCompareFunc);
      {-Sort the array rows using the given comparison function and
        the elements in the given column}

    property Rows : Cardinal
      {-Read or write the number of rows in the array}
      read FRows
      write lmSetRows;
    property Cols : Cardinal
      {-Read or write the number of columns in the array}
      read FCols
      write lmSetCols;
    property ElementSize : Integer                                     
      read FElSize;
    property ElementsStorable : boolean
      {-True if elements can be written directly to (or read from) disk}
      read FElStorable write FElStorable;
  end;

{======================================================================}

implementation

function AssignArrayData(Container : TStContainer;
                     var Data;
                         OtherData : Pointer) : Boolean; far;
  var
    OurArray : TStLArray absolute OtherData;
    RD : TAssignRowData absolute Data;
  begin
    OurArray.Put(RD.RowNum, RD.Data);
    Result := true;
  end;

function AssignMatrixData(Container : TStContainer;
                      var Data;
                          OtherData : Pointer) : Boolean; far;
  var
    OurMatrix : TStLMatrix absolute OtherData;
    RD : TAssignRowData absolute Data;
  begin
    OurMatrix.PutRow(RD.RowNum, RD.Data);
    Result := true;
  end;

procedure TStLArray.Assign(Source: TPersistent);
  begin
    {$IFDEF ThreadSafe}
    EnterCS;
    try
    {$ENDIF}
      {The only containers that we allow to be assigned to a large array
       are:
         - another SysTools large array (TStLArray)
         - a SysTools large matrix (TStLMatrix) with one column
         - a SysTools virtual matrix (TStVMatrix) with one column}
      if not AssignUntypedVars(Source, AssignArrayData) then
        inherited Assign(Source);
    {$IFDEF ThreadSafe}
    finally
      LeaveCS;
    end;{try..finally}
    {$ENDIF}
  end;

procedure TStLArray.Clear;
var
  C : LongInt;                                                         
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    C := FCount;
    HugeFillChar(laData^, C*FElSize, 0);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStLArray.ForEachUntypedVar(Action : TIterateUntypedFunc;
                                      OtherData : pointer);
  var
    FullRow : ^TAssignRowData;
    i       : Cardinal;
  begin
  {$IFDEF ThreadSafe}
    EnterCS;
    try
  {$ENDIF}
      GetMem(FullRow, sizeof(Cardinal) + ElementSize);
      try
        for i := 0 to pred(Count) do
          begin
            FullRow^.RowNum := i;
            Get(i, FullRow^.Data);
            Action(Self, FullRow^, OtherData);
          end;
      finally
        FreeMem(FullRow, sizeof(Cardinal) + ElementSize);
      end;
  {$IFDEF ThreadSafe}
    finally
      LeaveCS;
    end;
  {$ENDIF}
  end;

procedure TStLArray.GetArraySizes(var RowCount, ColCount, ElSize : Cardinal);
begin
  RowCount := Count;
  ColCount := 1;
  ElSize := ElementSize;
end;

procedure TStLArray.SetArraySizes(RowCount, ColCount, ElSize : Cardinal);
begin
  if (ColCount <> 1) then
    RaiseContainerError(stscTooManyCols);
  if (LongInt(RowCount) <> Count) or
     (LongInt(ElSize) <> ElementSize) then begin
    HugeFreeMem(laData, FCount*FElSize);
    FCount := RowCount;
    FElSize := ElSize;
    HugeGetMem(laData, RowCount*ElSize);
    Clear;
  end;
end;

function TStLArray.StoresUntypedVars : boolean;
begin
  Result := True;
end;

constructor TStLArray.Create(Elements : LongInt; ElementSize : Cardinal);
begin
  if (Elements <= 0) or (ElementSize = 0) or
  ProductOverflow(Elements, ElementSize) then
    RaiseContainerError(stscBadSize);

  CreateContainer(TStNode, 0);

  FCount := Elements;
  FElSize := ElementSize;

  HugeGetMem(laData, Elements*LongInt(ElementSize));
  Clear;
end;

destructor TStLArray.Destroy;
begin
  HugeFreeMem(laData, FCount*FElSize);
  IncNodeProtection;
  inherited Destroy;
end;

procedure TStLArray.Exchange(El1, El2 : LongInt);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
{$IFOPT R+}
    if (El1 < 0) or (El1 >= Count) or (El2 < 0) or (El2 >= Count) then
      RaiseContainerError(stscBadIndex);
{$ENDIF}
    asm
      mov eax,Self
      push ebx
      push esi
      push edi

      mov esi,El1
      mov edi,El2
      mov ecx,TStLArray([eax]).FElSize
      mov edx,TStLArray([eax]).laData
      db $0F,$AF,$F1            {imul esi,ecx, compiler bug workaround}
      add esi,edx
      db $0F,$AF,$F9            {imul edi,ecx, compiler bug workaround}
      add edi,edx
      mov edx,ecx
      shr ecx,2
      jz @2

  @1: mov eax,[esi]             {avoid xchg instruction, which is slow}
      mov ebx,[edi]
      mov [esi],ebx
      mov [edi],eax
      add esi,4
      add edi,4
      dec ecx
      jnz @1

  @2: mov ecx,edx
      and ecx,3
      jz @4

  @3: mov al,[esi]              {avoid xchg instruction, which is slow}
      mov bl,[edi]
      mov [esi],bl
      mov [edi],al
      inc esi
      inc edi
      dec ecx
      jnz @3

  @4: pop edi
      pop esi
      pop ebx
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;


procedure TStLArray.Fill(const Value);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    HugeFillStruc(laData^, FCount, Value, FElSize);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStLArray.Get(El : LongInt; var Value);
(* model for code below
begin
  move((PChar(laData)+El*FElSize)^, Value, FElSize);
end;
*)
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
{$IFOPT R+}
    if (El < 0) or (El >= Count) then
      RaiseContainerError(stscBadIndex);
{$ENDIF}
    asm
      mov eax,Self
      push esi
      push edi
      mov edi,Value
      mov ecx,TStLArray([eax]).FElSize
      mov esi,El
      db $0F,$AF,$F1     {imul esi,ecx, compiler bug workaround}
      add esi,TStLArray([eax]).laData
      mov eax,ecx
      shr ecx,2
      rep movsd
      mov ecx,eax
      and ecx,3
      rep movsb
      pop edi
      pop esi
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;


procedure TStLArray.laSetCount(Elements : LongInt);
var
  CurSize, NewSize : LongInt;
  CurFData : Pointer;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    {validate new size}
    if (Elements <= 0) or ProductOverflow(Elements, FElSize) then
      RaiseContainerError(stscBadSize);

    NewSize := Elements*FElSize;                            
    CurSize := FCount*FElSize;
    CurFData := laData;

    {allocate data block of new size}
    HugeGetMem(laData, NewSize);

    FCount := Elements;

    {fill extra area with zeros and copy old data}
    if NewSize > CurSize then begin
      Clear;