stlarr.pas

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

      NewSize := CurSize;
    end;
    HugeMove(CurFData^, laData^, NewSize);

    {free original data area}
    HugeFreeMem(CurFData, CurSize);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStLArray.Put(El : LongInt; const Value);
(* model for assembly language below
begin
  move(Value, (PChar(laData)+Row*FElSize)^, 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 esi,Value
      mov ecx,TStLArray([eax]).FElSize
      mov edi,El
      db $0F,$AF,$F9            {imul edi,ecx, compiler bug workaround}
      add edi,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.Sort(Compare : TUntypedCompareFunc);
const
  StackSize = 32;
type
  Stack = array[0..StackSize-1] of LongInt;
var
  L : LongInt;
  R : LongInt;
  PL : LongInt;
  PR : LongInt;
  CurEl : Pointer;
  PivEl : Pointer;
  StackP : Integer;
  LStack : Stack;
  RStack : Stack;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    {Need at least 2 elements to sort}
    if FCount <= 1 then
      Exit;

    GetMem(CurEl, FElSize);
    try
      GetMem(PivEl, FElSize);
      try
        {Initialize the stacks}
        StackP := 0;
        LStack[0] := 0;
        RStack[0] := FCount-1;

        {Repeatedly take top partition from stack}
        repeat

          {Pop the stack}
          L := LStack[StackP];
          R := RStack[StackP];
          Dec(StackP);

          {Sort current partition}
          repeat

            {Load the pivot element}
            Get((L+R) div 2, PivEl^);
            PL := L;
            PR := R;

            {Swap items in sort order around the pivot index}
            repeat
              Get(PL, CurEl^);
              while Compare(CurEl^, PivEl^) < 0 do begin
                Inc(PL);
                Get(PL, CurEl^);
              end;
              Get(PR, CurEl^);
              while Compare(PivEl^, CurEl^) < 0 do begin
                Dec(PR);
                Get(PR, CurEl^);
              end;
              if PL <= PR then begin
                if PL <> PR then
                  {Swap the two elements}
                  Exchange(PL, PR);
                Inc(PL); {assume we'll never sort 2 billion elements}
                Dec(PR);
              end;
            until PL > PR;

            {Decide which partition to sort next}
            if (PR-L) < (R-PL) then begin
              {Right partition is bigger}
              if PL < R then begin
                {Stack the request for sorting right partition}
                Inc(StackP);
                LStack[StackP] := PL;
                RStack[StackP] := R;
              end;
              {Continue sorting left partition}
              R := PR;
            end else begin
              {Left partition is bigger}
              if L < PR then begin
                {Stack the request for sorting left partition}
                Inc(StackP);
                LStack[StackP] := L;
                RStack[StackP] := PR;
              end;
              {Continue sorting right partition}
              L := PL;
            end;

          until L >= R;
        until StackP < 0;
      finally
        FreeMem(PivEl, FElSize);
      end;
    finally
      FreeMem(CurEl, FElSize);
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStLArray.LoadFromStream(S : TStream);
var
  Data         : pointer;
  Reader       : TReader;
  NumElements  : longint;
  ElementSize  : LongInt;                                              
  i            : longint;
  TotSize      : longint;
  StreamedClass : TPersistentClass;
  StreamedClassName : string;
  Value        : TValueType;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Clear;
    Reader := TReader.Create(S, 1024);
    try
      with Reader do
        begin
          StreamedClassName := ReadString;
          StreamedClass := GetClass(StreamedClassName);
          if (StreamedClass = nil) then
            RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
          if (not IsOrInheritsFrom(StreamedClass, Self.ClassType)) or
              (not IsOrInheritsFrom(TStLArray, StreamedClass)) then
            RaiseContainerError(stscWrongClass);
          NumElements := ReadInteger;
          ElementSize := ReadInteger;
          if (NumElements <> FCount) or (ElementSize <> FElSize) then
            begin
              HugeFreeMem(laData, FCount*FElSize);
              FCount := NumElements;
              FElSize := ElementSize;
              HugeGetMem(laData, NumElements*ElementSize);
              Clear;
            end;
          ElementsStorable := ReadBoolean;
          if ElementsStorable then
            begin
              Read(Value, sizeof(Value)); {s/b vaBinary}
              Read(TotSize, sizeof(longint));
              GetMem(Data, FElSize);
              try
                for i := 0 to pred(FCount) do
                  begin
                    Read(Data^, FElSize);
                    Put(i, Data^);
                  end;
              finally
                FreeMem(Data, FElSize);
              end;
            end
          else
            begin
              ReadListBegin;
              for i := 0 to pred(FCount) do begin
                Data := DoLoadData(Reader);
                Put(i, Data^);
              end;
              ReadListEnd;
            end;
        end;
    finally
      Reader.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStLArray.StoreToStream(S : TStream);
var
  Writer : TWriter;
  i      : integer;
  Data   : pointer;
  TotSize: longint;
  Value  : TValueType;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Writer := TWriter.Create(S, 1024);
    try
      GetMem(Data, FElSize);
      try
        with Writer do begin
          WriteString(Self.ClassName);
          WriteInteger(FCount);
          WriteInteger(FElSize);
          WriteBoolean(FElStorable);
          if ElementsStorable then begin
            Value := vaBinary;
            Write(Value, sizeof(Value));
            TotSize := FCount * FElSize;
            Write(TotSize, sizeof(longint));
            for i := 0 to pred(FCount) do begin
              Get(i, Data^);
              Write(Data^, FElSize);
            end;
          end else begin
            WriteListBegin;
            for i := 0 to pred(FCount) do begin
              Get(i, Data^);
              DoStoreData(Writer, Data);
            end;
            WriteListEnd;
          end;
        end;
      finally
        FreeMem(Data, FElSize);
      end;
    finally
      Writer.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

{----------------------------------------------------------------------}

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

procedure TStLMatrix.Clear;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    HugeFillChar(lmData^, FCount*FElSize, 0);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

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

procedure TStLMatrix.GetArraySizes(var RowCount, ColCount, ElSize : Cardinal);
begin
  RowCount := Rows;
  ColCount := Cols;
  ElSize := ElementSize;
end;

procedure TStLMatrix.SetArraySizes(RowCount, ColCount, ElSize : Cardinal);
begin
  if (RowCount <> Rows) or (ColCount <> Cols) or
     (LongInt(ElSize) <> ElementSize) then                             
    begin
      HugeFreeMem(lmData, FCount*FElSize);
      FElSize := ElSize;
      FRows := RowCount;
      FCols := ColCount;
      {$IFDEF VERSION4}
      FCount := RowCount*ColCount;
      lmRowSize := ColCount*ElSize;
      HugeGetMem(lmData, FCount*LongInt(ElSize));
      {$ELSE}
      FCount := LongInt(RowCount)*ColCount;
      lmRowSize := LongInt(ColCount)*ElSize;
      HugeGetMem(lmData, FCount*ElSize);
      {$ENDIF}
      Clear;
    end;
end;

function TStLMatrix.StoresUntypedVars : boolean;
begin
  Result := true;
end;

constructor TStLMatrix.Create(Rows, Cols, ElementSize : Cardinal);
begin
  CreateContainer(TStNode, 0);

  FElSize := ElementSize;
  FRows := Rows;
  FCols := Cols;
  FCount := LongInt(Rows)*LongInt(Cols);
  lmRowSize := LongInt(Cols)*LongInt(ElementSize);

  if (Rows = 0) or (Cols = 0) or (ElementSize = 0) or
  ProductOverflow(FCount, ElementSize) then
    RaiseContainerError(stscBadSize);

  HugeGetMem(lmData, FCount*LongInt(ElementSize));                     
  Clear;
end;

destructor TStLMatrix.Destroy;
begin
  HugeFreeMem(lmData, FCount*FElSize);
  IncNodeProtection;
  inherited Destroy;
end;

procedure TStLMatrix.ExchangeRows(Row1, Row2 : Cardinal);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
{$IFOPT R+}
    if (Row1 >= Rows) or (Row2 >= Rows) then
      RaiseContainerError(stscBadIndex);
{$ENDIF}
    asm
      mov eax,Self
      push ebx
      push esi
      push edi

      mov esi,Row1
      mov edi,Row2
      mov ecx,TStLMatrix([eax]).lmRowSize
      mov edx,TStLMatrix([eax]).lmData
      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 TStLMatrix.Fill(const Value);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    HugeFillStruc(lmData^, FCount, Value, FElSize);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;