dynamicarrays.pas

delphi通过OCI访问ORACLE

  end;

procedure memcpy(pi,po:pointer;Count:integer); stdcall;
procedure memclr(po:pointer;Count:integer); stdcall;
procedure memset(po:pointer;Value:byte;Count:integer); stdcall;

function memfinddword(pi:pointer;Value:dword;Count:integer):integer; stdcall;
function memfindbyte(pi:pointer;Value:byte;Count:integer):integer; stdcall;
function memfindword(pi:pointer;Value:word;Count:integer):integer; stdcall;
function memfindint64(pi:pointer;Value:int64;Count:integer):integer; stdcall;
function memfindgeneral(pi,pValue:pointer;ValueSize:integer;Count:integer):integer; stdcall;

implementation

uses SysUtils;

const
 BLOCK=1024;

function HGetToken(InputString:string; Delimiters:string; OnlyOneDelimiter:boolean; Index:integer):string;
var i,p:integer;
begin
 Result:='';
 p:=1;
 while (p<=length(InputString)) and (pos(InputString[p],Delimiters)<>0) do
  inc(p);
 for i:=1 to index do begin
  while (p<=length(InputString)) and (pos(InputString[p],Delimiters)=0)
   do inc(p);

  if OnlyOneDelimiter
   then  inc(p)
   else  while (p<=length(InputString)) and (pos(InputString[p],Delimiters)<>0) do inc(p);
 end;
 while (p<=length(InputString)) and (pos(InputString[p],Delimiters)=0)
  do begin Result:=Result+InputString[p]; inc(p); end;
end;

function HGetTokenCount(InputString:string; Delimiters:string; OnlyOneDelimiter:boolean):integer;
var p:integer;
begin
 Result:=0;
 if InputString='' then exit;
 p:=1;
 while (p<=length(InputString)) and (pos(InputString[p],Delimiters)<>0) do
  inc(p);
 while (p<=length(InputString)) do begin
  while (p<=length(InputString)) and (pos(InputString[p],Delimiters)=0)
    do inc(p);

  if OnlyOneDelimiter
   then  inc(p)
   else  while (p<=length(InputString)) and (pos(InputString[p],Delimiters)<>0) do inc(p);
  Result:=Result+1;
 end;
 Result:=Result;
end;

procedure memcpy(pi,po:pointer;Count:integer); stdcall;
begin
 if ((dword(pi)+dword(Count))>dword(po)) and (dword(pi)<dword(po)) then // copy from end
 asm
  pushad
  pushfd
  mov ECX,Count
  mov EDI,po
  mov ESI,pi
  add ESI,ECX
  add EDI,ECX
  dec ESI
  dec EDI
  std
  repne MOVSB
  popfd
  popad
 end else // copying from begin
 asm
  pushad
  pushfd
  mov ECX,Count
  mov EDI,po
  mov ESI,pi
  cld
  repne MOVSB
  popfd
  popad
 end;
end;

procedure memclr(po:pointer;Count:integer); stdcall;
//begin
 asm
  pushad
  pushfd
  mov ECX,Count
  mov EDI,po
  xor AL,AL
  cld
  repne STOSB
  popfd
  popad
 end;
//end;

procedure memset(po:pointer;Value:byte;Count:integer); stdcall;
//begin
 asm
  pushad
  pushfd
  mov ECX,Count
  mov EDI,po
  mov AL,Value
  cld
  repne STOSB
  popfd
  popad
 end;
//end;

function memfinddword(pi:pointer;Value:dword;Count:integer):integer; stdcall;
//label ex;
//begin
 asm
  pushad
  pushfd
  mov Result,0
  mov ECX,Count
  cmp ECX,0
  jz @ex
  mov EAX,Value
  mov EDI,pi
  cld
  repne SCASD
  jne @ex
  mov EAX,Count
  sub EAX,ECX
  mov Result,EAX
@ex:
  dec Result
  popfd
  popad
 end;
//end;

function memfindbyte(pi:pointer;Value:byte;Count:integer):integer; stdcall;
//label ex;
//begin
 asm
  pushad
  pushfd
  mov @Result,0
  mov ECX,Count
  cmp ECX,0
  jz @ex
  mov AL,Value
  mov EDI,pi
  cld
  repne SCASB
  jne @ex
  mov EAX,Count
  sub EAX,ECX
  mov @Result,EAX
@ex:
  dec @Result
  popfd
  popad
 end;
//end;

function memfindword(pi:pointer;Value:word;Count:integer):integer; stdcall;
//label ex;
//begin
 asm
  pushad
  pushfd
  mov @Result,0
  mov ECX,Count
  cmp ECX,0
  jz @ex
  mov AX,Value
  mov EDI,pi
  cld
  repne SCASW
  jne @ex
  mov EAX,Count
  sub EAX,ECX
  mov @Result,EAX
@ex:
  dec @Result
  popfd
  popad
 end;
//end;

function memfindint64(pi:pointer;Value:int64;Count:integer):integer; stdcall;
asm
  pushad
  pushfd
  mov @Result,0
  mov ECX,Count
  cmp ECX,0
  jz @ex
  mov EAX,dword ptr Value
  mov EBX,dword ptr (Value+4)
  mov EDI,pi
@loop:
  cmp EAX,[EDI]
  je @found1
  dec ECX
  jz @ex
  add EDI,8     // go to next int 64 value
  jmp @loop
@found1:
  add EDI,4     // go to next half of current int64 value
  cmp EBX,[EDI]
  je @found2
  dec ECX
  jz @ex
  add EDI,4
  jmp @loop
@found2:
  mov EAX,Count
  sub EAX,ECX
  mov @Result,EAX
@ex:
  dec @Result
  popfd
  popad
end;

function memfindgeneral(
  pi:pointer;        // start address for finding
  pValue:pointer;    // pointer to the finding value
  ValueSize:integer; // the size of finding value in bytes
  Count:integer      // number of values in array
  ):integer; stdcall;
 asm
  pushad
  pushfd
  mov @Result,0
  mov EBX,Count
  cmp EBX,0
  jz @ex
  mov EDI,pi
@loop:
  mov ESI,pValue
  mov ECX,ValueSize;
  cld
  repe CMPSB
  jz @ex1
  add EDI,ECX       
  dec EBX
  jnz @loop
  jmp @ex
@ex1:
  dec EBX
  mov EAX,Count
  sub EAX,EBX
  mov @Result,EAX
@ex:
  dec @Result
  popfd
  popad
 end;

 { THArray }

constructor THArray.Create;
begin
 inherited Create;

 FCount:=0;
 FCapacity:=0;
 FItemSize:=1;
 FValues:=nil;
end;

destructor THArray.Destroy;
begin
 ClearMem;
 FItemSize:=0;
 inherited Destroy;
end;

procedure THArray.Delete(num:integer);
begin
 if num>=FCount then raise ERangeError.Create(Format(SItemNotFound,[num]));
 if num<(FCount-1) then memcpy(GetAddr(num+1),GetAddr(num),(FCount-num-1)*FItemSize);
 Dec(FCount);
end;

procedure THArray.Clear;
begin
 FCount:=0;
end;

procedure THArray.ClearMem;
begin
 FCount:=0;
 FCapacity:=0;
 FreeMem(FValues);
 FValues:=nil;
end;

function THArray.Add(pValue:pointer):integer;
begin
 Result:=Insert(FCount,pValue);
end;

procedure THArray.AddMany(pValue:pointer;Count:integer);
begin
 if Count<=0 then exit;
 InsertMany(FCount,pValue,Count);
end;

procedure THarray.Hold;
// frees unused memory
begin
 SetCapacity(FCount);
end;

procedure THArray.SetCapacity(Value:integer);
begin
  ReAllocMem(FValues,Value*FItemSize);
  FCapacity:=Value;
  if FCount>FCapacity then FCount:=FCapacity;
end;

procedure THArray.AddFillValues(ACount:integer);
begin
 if Count+ACount>Capacity then GrowTo(Count+ACount);
 memclr(CalcAddr(FCount),ACount*ItemSize);
 FCount:=FCount+ACount;
end;

procedure THArray.Zero;
begin
 if FCount=0 then exit;
 memclr(Memory,FCount*ItemSize);
end;

procedure THArray.Grow;
// allocates memory for more number of elements by the next rules
//     the size of allocated memory increases on 25% if array has more than 64 elements
//     the size of allocated memory increases on 16 elements if array has from 8 to 64 elements
//     the size of allocated memory increases on 4 elements if array has less than 8 elements
var Delta:integer;
begin
 if FCapacity > 64 then Delta := FCapacity div 4 else
   if FCapacity > 8 then Delta := 16 else Delta := 4;
 SetCapacity(FCapacity + Delta);
end;

procedure THArray.GrowTo(Count:integer);
// increases size of allocated memory till Count elements (if count enough large) or
// to a number as described in Grow procedure
var Delta:integer;
begin
 if Count<=FCapacity then exit;

 if FCapacity > 64 then Delta := FCapacity div 4 else
   if FCapacity > 8 then Delta := 16 else Delta := 4;
 if (FCapacity+Delta)<Count then Delta:=Count-FCapacity;
 SetCapacity(FCapacity + Delta);
end;

function THArray.Insert(num:integer;pValue:pointer):integer;
begin
 Error(num,0,FCount);
 inc(FCount);
 if FCount>=FCapacity then Grow;

 memcpy(CalcAddr(num),CalcAddr(num+1),(FCount-num-1)*FItemSize); // make place to insert
 Update(num,pValue);
 Result:=num;
end;

procedure THArray.InsertMany(num:integer;pValue:pointer;Count:integer);
begin
 Error(num,0,FCount);
 if FCount+Count>FCapacity then GrowTo(FCount+Count);

 FCount:=FCount+Count;
 memcpy(CalcAddr(num),CalcAddr(num+Count),(FCount-num-Count)*FItemSize);
 UpdateMany(num,pValue,Count);
end;

procedure THArray.Update(num:integer;pValue:pointer);
begin
 if pValue=nil
  then memclr(GetAddr(num),FItemSize)
  else memcpy(pValue,GetAddr(num),FItemSize);
end;

procedure THArray.UpdateMany(num:integer;pValue:pointer;Count:integer);
begin
 Error(num+Count,0,FCount);
 memcpy(pValue,GetAddr(num),FItemSize*Count);
end;

procedure THArray.Get(num:integer;pValue:pointer);
begin
 memcpy(GetAddr(num),pValue,FItemSize);
end;

function THArray.GetAddr(num:integer):pointer;
begin
 Error(num,0,FCount-1);
 Result:=CalcAddr(num);
end;

function THArray.CalcAddr(num:integer):pointer;
begin
 Result:=pointer(dword(FValues)+dword(num)*dword(FItemSize));
end;

procedure THArray.Error(Value,min,max:integer);
begin
  if (Value<min) or (Value>max) then raise ERangeError.Create(Format(SItemNotFound,[Value]));
end;

procedure THArray.SetItemSize(Size:integer);
begin
 ClearMem;
 if (FCount=0) and (Size>0) then FItemSize:=Size;
end;

procedure THArray.MoveData(FromPos,Count,Offset:integer);
var mem:pointer;
begin
 Error(FromPos,0,FCount-1);
 Error(FromPos+Count,0,FCount);
 Error(FromPos+Offset,0,FCount-1);
 Error(FromPos+Offset+Count,0,FCount);
 mem:=AllocMem(Count*FItemSize);
 try
  memcpy(CalcAddr(FromPos),mem,Count*FItemSize);
  if Offset<0 then memcpy(CalcAddr(FromPos+Offset),CalcAddr(FromPos+Offset+Count),(-Offset)*FItemSize);
  if Offset>0 then memcpy(CalcAddr(FromPos+Count),CalcAddr(FromPos),Offset*FItemSize);
  memcpy(mem,CalcAddr(FromPos+Offset),Count*FItemSize);
 finally
  FreeMem(mem);
 end; 
end;

procedure THArray.Sort(CompareProc : TCompareProc);
var
  maxEl : integer;
  i,j   : integer;
begin
  if Count<2 then exit;
  if @CompareProc=nil then exit;

  for i:=0 to Count-2 do
   begin
    maxEl:=i;
    for j:=i+1 to Count-1 do
      if CompareProc(self,maxEl,j)<0 then maxEl:=j;
    if maxEl<>i then
     begin
      Swap(i,maxEl);
//      MoveData(i,1,maxEl-i);
//      MoveData(maxEl-1,1,i-maxEl+1);
    end;
  end;
end;

procedure THArray.Swap(Index1, Index2: integer);
var p:pointer;
begin
 p:=AllocMem(FItemSize);
 try
  memcpy(GetAddr(Index1),p,FItemSize);
  memcpy(GetAddr(Index2),GetAddr(Index1),FItemSize);
  memcpy(p,GetAddr(Index2),FItemSize);
 finally
  FreeMem(p);
 end; 
end;

procedure THArray.QuickSort(CompareProc: TCompareProc; SwapProc: TSwapProc);
begin
 InternalQuickSort(CompareProc,SwapProc,0,Count-1);
end;

procedure THArray.InternalQuickSort(CompareProc: TCompareProc;
  SwapProc: TSwapProc; L, R: integer);
var
  I,J: Integer;
  P: Integer;
begin
  if @CompareProc=nil then exit;
{  repeat
    I := L;
    J := R;
    P := (L + R) shr 1;
    repeat
      while CompareProc(self,I,P) < 0 do Inc(I);
      while CompareProc(self,J,P) > 0 do Dec(J);
      if I <= J then
      begin
        SwapProc(self,I,J);
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then
     InternalQuickSort(CompareProc,SwapProc, L, J);
    L := I;
  until I >= R;}

    I := L;
    J := R;
    P := (L + R) shr 1;
    repeat
      while ((CompareProc(self,I,P) < 0){and(I<=J)}) do Inc(I);
      while ((CompareProc(self,J,P) > 0){and(I<=J)}) do Dec(J);
      if I <= J then
      begin
        if I=P then P:=J
         else if J=P then P:=I;
        if @SwapProc=nil
         then Swap(I,J)
         else SwapProc(self,I,J);
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then InternalQuickSort(CompareProc,SwapProc, L, J);
    if I < R then InternalQuickSort(CompareProc,SwapProc, I, R);