rm_stbase.pas

这是一个功能强大

{$ENDIF}
{.Z-}


{---primitives for converting strings to integers}
procedure ValLongInt(S : ShortString; var LI : Longint; var ErrorCode : integer);
procedure ValSmallint(const S : ShortString; var SI : smallint; var ErrorCode : integer);
procedure ValWord(const S : ShortString; var Wd : word; var ErrorCode : integer);

{.Z+}
{general routine to raise a specific class of SysTools exception}
procedure RaiseStError(ExceptionClass : EStExceptionClass; Code : LongInt);
{.Z-}

{.Z+}
{general routines to raise a specific Win32 exception in SysTools}
procedure RaiseStWin32Error(ExceptionClass : EStExceptionClass; Code : LongInt);
procedure RaiseStWin32ErrorEx(ExceptionClass : EStExceptionClass; Code : LongInt; Info : string);
{.Z-}

{$IFDEF VERSION3ONLY}
var
  StHexDigitsW : WideString;
  DosDelimSetW : WideString;
{$ENDIF}


implementation

procedure RaiseStError(ExceptionClass : EStExceptionClass; Code : LongInt);
var
  E : EStException;
begin
  E := ExceptionClass.CreateResTP(Code, 0);
  E.ErrorCode := Code;
  raise E;
end;

procedure RaiseStWin32Error(ExceptionClass : EStExceptionClass; Code : LongInt);
var
  E : EStException;
begin
  E := ExceptionClass.Create(SysErrorMessage(Code));
  E.ErrorCode := Code;
  raise E;
end;

procedure RaiseStWin32ErrorEx(ExceptionClass : EStExceptionClass; Code : LongInt;
          Info : string);
var
  E : EStException;
begin
  E := ExceptionClass.Create(SysErrorMessage(Code) + ' [' + Info + ']');
  E.ErrorCode := Code;
  raise E;
end;

constructor EStException.CreateResTP(Ident : LongInt; Dummy : Word);
begin
  inherited Create(SysToolsStr(Ident));
end;

constructor EStException.CreateResFmtTP(Ident : Longint;
            const Args : array of const; Dummy : Word);
begin
  inherited CreateFmt(SysToolsStr(Ident), Args);
end;

constructor EStExprError.CreateResTPCol(Ident : Longint; Column : Integer; Dummy : Integer);
begin
  inherited CreateResTP(Ident, 0);

  FErrorCol := Column;
end;


function AbstractCompare(Data1, Data2 : Pointer) : Integer; far;
begin
  raise ESTContainerError.CreateResTP(stscNoCompare, 0);
end;

{$IFDEF WStrings}
function AnsiCompareStrShort32(const S1, S2: string): Integer; assembler;
asm
  push esi
  push edi
  mov esi,S1
  mov edi,S2
  xor eax,eax
  xor edx,edx
  xor ecx,ecx
  mov dl,[esi]
  inc esi
  mov dh,[edi]
  inc edi
  mov cl,dl
  cmp cl,dh
  jbe @1
  mov cl,dh
@1:
  or ecx, ecx
  je @CheckLengths
  repe cmpsb
  jb @LT
  ja @GT
@CheckLengths:
  cmp dl, dh
  je @Exit
  jb @LT
@GT:
  inc eax
  inc eax
@LT:
  dec eax
@Exit:
  pop edi
  pop esi
end;

function AnsiCompareTextShort32(const S1, S2: string): Integer;
begin
  Result := AnsiCompareStrShort32(AnsiUpperCaseShort32(S1),
                                  AnsiUpperCaseShort32(S2));
end;

function AnsiUpperCaseShort32(const S : string) : string;
begin
  Result := S;
  AnsiUpperBuff(PChar(@Result[1]), Length(S));
end;
{$ENDIF}

function DestroyNode(Container : TStContainer;
                     Node : TStNode;
                     OtherData : Pointer) : Boolean;
begin
  Container.DisposeNodeData(Node);
  Node.Free;
  Result := True;
end;

procedure HugeFillChar(var Dest; Count : Longint; Value : Byte);
begin
  FillChar(Dest, Count, Value);
end;

function HugeCompressRLE(const InBuffer; InLen : Longint;
                         var OutBuffer) : Longint;
    {assumes OutBuffer is at least InLen long}
    {returns -1 if InLen <= 1 or if output length would exceed InLen}
    {otherwise returns compressed length}
    {does not initialize OutBuffer if the result is -1}
  asm
    {InBuffer = eax, InLen = edx, OutBuffer = ecx}
    push ebx
    push esi
    push edi

    push OutBuffer       {save output base for later}

    cmp InLen,1
    jle @A               {can't compress if input length <= 1}

    mov esi,InBuffer     {esi = current input offset}
    mov edi,OutBuffer    {edi = current output offset}
    mov eax,InLen
    mov ebx,edi          {ebx = control byte offset}
    mov byte ptr [ebx],0 {reset first control byte}
    mov edx,edi
    add edx,eax          {edx = endpoint of output buffer}
    dec edx              {reserve an extra space for control byte}
    mov ecx,esi
    add ecx,eax          {ecx = endpoint of input buffer}
    dec ecx              {reduce by one for convenience below}
    dec esi              {decrement first time through}

@1: inc esi              {next input byte}
    cmp esi,ecx
    ja  @9               {exit at end of input}
    mov al,[esi]         {load compare byte}
    jae @5               {can't be a match if on last byte of input}
    cmp [esi+1],al       {is it a run?}
    jne @5               {jump if not}

    {starting a run}
    mov ebx,edi          {start a new control sequence}
    mov byte ptr [ebx],1 {first byte in run}
    mov [ebx+1],al       {store run byte}
@2: inc esi              {next input byte}
    cmp esi,ecx          {end of input?}
    ja  @3               {exit this loop if so}
    cmp [esi],al         {next byte a match?}
    jne @3               {jump if not a run}
    cmp byte ptr [ebx],StRLEMaxCount {max run length?}
    je  @3               {exit this loop if so}
    inc byte ptr [ebx]   {increment control byte}
    jmp @2               {stay in the run loop}
@3: or byte ptr [ebx],StRLERunMode {flag control byte as a run}
    inc edi              {step past control and run bytes}
    inc edi
    cmp edi,edx          {filled up output buffer?}
    jae @A               {jump if so}
    mov ebx,edi          {set up new control byte}
    mov byte ptr [ebx],0 {first byte in non-run}
    dec esi              {back up one byte}
    jmp @1               {classify run status again}

@5: {not a run}
    cmp edi,ebx          {the start of a new non-run?}
    ja  @6               {jump if not}
    inc edi              {next output position, guaranteed ok}
@6: cmp byte ptr [ebx],StRLEMaxCount {max non-run length?}
    jb  @7
    mov ebx,edi          {start a new control sequence}
    mov byte ptr [ebx],0 {reset control byte}
    inc edi              {next output position}
    cmp edi,edx          {filled up output buffer?}
    jae @A               {jump if so}
@7: inc byte ptr [ebx]   {increment control byte}
    mov [edi],al         {copy input byte}
    inc edi              {next output position}
    cmp edi,edx          {filled up output buffer?}
    jae @A               {jump if so}
    jmp @1               {back to outer loop}

@9: pop eax              {get output base again}
    sub edi,eax          {get output length}
    jmp @B
@A: pop eax              {balance stack}
    mov edi,-1           {could not compress input}
@B: mov eax,edi          {return output length}

    pop edi
    pop esi
    pop ebx
  end;

function HugeDecompressRLE(const InBuffer; InLen : Longint;
                           var OutBuffer; OutLen : LongInt) : Longint;
    {returns -1 if InLen is <= 0 or output length > OutLen}
    {otherwise returns decompressed length}
  asm
    {InBuffer = eax, InLen = edx, OutBuffer = ecx, OutLen = stack}
    push ebx
    push esi
    push edi

    push OutBuffer       {save output base for later}

    cmp InLen,0          {anything to decompress?}
    jle @A               {jump if not}

    mov esi,InBuffer     {esi = current input offset}
    mov edi,OutBuffer    {edi = current output offset}
    mov ebx,esi
    add ebx,InLen        {ebx = endpoint of input buffer}
    mov edx,OutLen       {edx = space free in output buffer}

@1: cmp esi,ebx          {end of input?}
    jae @9               {jump if so}
    mov al,[esi]         {get next control byte}
    inc esi              {move to run data byte}
    mov cl,al
    and ecx,StRLEMaxCount{ecx = bytes for output}
    sub edx,ecx          {is there space?}
    jc  @A               {jump if not}
    test al,StRLERunMode {is it a run?}
    jz @5                {jump if not}

    {a run}
    mov al,[esi]         {get run data}
    inc esi              {next input position}
    rep stosb            {store it}
    jmp @1               {loop}

@5: {not a run}
    rep movsb            {copy them}
    jmp @1               {loop}

@9: pop eax              {get output base again}
    sub edi,eax          {get output length}
    jmp @B
@A: pop eax              {balance stack}
    mov edi,-1           {could not decompress input}
@B: mov eax,edi          {return output length}

    pop  edi
    pop  esi
    pop  ebx
  end;

procedure HugeFillStruc(var Dest; Count : Longint;
                        const Value; ValSize : Cardinal); assembler;
register;
  asm
    {eax = Dest, edx = Count, ecx = Value}
    push ebx
    push esi
    push edi
    mov edi,Dest            {edi -> Dest}
    mov eax,Value           {eax -> Value}
    {mov edx,Count}         {edx = Count, register parameter}
    mov ebp,ValSize         {ebp = ValSize}
    jmp @2
@1: mov ecx,ebp             {ecx = element ValSize}
    mov esi,eax             {esi -> Value}
    mov bx,cx
    shr ecx,2
    rep movsd
    mov cx,bx
    and cx,3
    rep movsb
@2: sub edx,1               {decrement elements left to fill}
    jnc @1                  {loop for all elements}
    pop edi
    pop esi
    pop ebx
  end;

procedure HugeFreeMem(var P : Pointer; Size : LongInt);
begin
  if Assigned(P) then begin
    FreeMem(P, Size);
    P := nil;
  end;
end;

procedure HugeGetMem(var P : Pointer; Size : LongInt);
begin
  GetMem(P, Size);
end;

procedure HugeMove(const Src; var Dest; Count : LongInt);
begin
  Move(Src, Dest, Count);
end;

function UpCase(C: AnsiChar) : AnsiChar;
asm
  and   eax, 0FFh
  push  eax
  call  CharUpper
end;

function LoCase(C: AnsiChar) : AnsiChar; assembler;
asm
  and   eax, 0FFh
  push  eax
  call  CharLower
end;

function ProductOverflow(A, B : LongInt) : Boolean;
register;
asm
  mov ecx,False
  {A is in eax already, B is in edx already}
  imul eax,edx
  jno @1
  mov ecx,True
@1:
  mov eax,ecx
end;

function CompareLetterSets(Set1, Set2 : LongInt) : Cardinal;
  {-Returns the sum of the values of the letters common to Set1 and Set2.}
asm
  push   ebx                       { Save registers }
  push   edi
  and    eax, edx                  { EAX = EAX and EDX }
  xor    edx, edx                  { Zero EDX }
  mov    ecx, ('Z'-'A')            { Set up counter }
  mov    edi, offset StLetterValues{ Point EBX to table }
  xor    ebx, ebx
  jmp    @@Start

@@Next:
  dec    ecx                       { Decrement counter }
  shl    eax, 1                    { Shift next bit into position }

@@Start:
  test   eax, 2000000h             { Test 26th bit }
  jnz    @@Add                     { If set, add corresponding letter value }
  or     ecx, ecx
  jz     @@Exit                    { Done if ECX is zero }
  jmp    @@Next                    { Test next bit }

@@Add:
  mov    bl, [ecx+edi]             { Do table lookup }
  add    edx, ebx                  { Add value to result }
  or     ecx, ecx
  jnz    @@Next                    { Test next bit }

@@Exit:
  mov    eax, edx                  { Move EDX to result }
  pop    edi                       { Restore registers }
  pop    ebx
end;

function CompStruct(const S1, S2; Size : Cardinal) : Integer;
  {-Compare two fixed size structures}
asm
  push   edi
  push   esi
  mov    esi, eax
  mov    edi, edx
  xor    eax, eax
  or     ecx, ecx
  jz     @@CSDone

  repe   cmpsb
  je     @@CSDone

  inc    eax
  ja     @@CSDone
  or     eax, -1

@@CSDone:
  pop    esi
  pop    edi
end;


function Search(const Buffer; BufLength : Cardinal; const Match;
                MatLength : Cardinal; var Pos : Cardinal) : Boolean;
asm
  push   ebx
  push   edi
  push   esi

  cld
  mov    edi, eax
  mov    ebx, eax
  mov    esi, ecx
  mov    ecx, edx
  mov    edx, MatLength
  or     edx, edx
  jz     @@NotFound

  mov    al, [esi]
  inc    esi
  dec    edx
  sub    ecx, edx
  jbe    @@NotFound

@@Next:
  repne  scasb
  jne    @@NotFound
  or     edx, edx
  jz     @@Found

  push   ecx
  push   edi
  push   esi

  mov    ecx, edx
  repe   cmpsb

  pop    esi
  pop    edi
  pop    ecx

  jne    @@Next            {Try again if no match}

{Calculate number of bytes searched and return}
@@Found:
  mov    esi, Pos
  dec    edi
  sub    edi, ebx
  mov    eax, 1
  mov    [esi], edi
  jmp    @@SDone

{Match was not found}
@@NotFound:
  xor    eax, eax

@@SDone:
  pop    esi
  pop    edi
  pop    ebx
end;

function SearchUC(const Buffer; BufLength : Cardinal; const Match;
                  MatLength: Cardinal; var Pos : Cardinal) : Boolean;

asm
  push   ebx                { Save registers }
  push   edi
  push   esi