mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-11-06 14:39:39 +01:00
d53cfa9c28
sparta: initial commit of "compilable" new sparta package - smart form editor. !NOTE: not for daily usage. ........ sparta: Initial conception for package for MDI: sparta_MDI. Base for sparta_DockedFormEditor package. ........ sparta: Generics.Collections library ( sync with https://github.com/dathox/generics.collections SHA fda586932bd80ef58c08f8ebf5a24316ca4ccca5) ........ sparta: smart form editor adjustment for new sparta_MDI ........ sparta: new class "TFormImpl" for MDI solution (created from TDesignedFormImpl). ........ sparta: -MDI form container "TFormContainer" -New IResizeFrame interface to handle MDI form moving -New frame TfrFormBackgroundForMDI ........ sparta: sparta_MDI package modifications: -new class TMultiplyResizer to menage MDI desktop -more generic resizer: TAbstractResizer. Base for IDE resizer and TMultiplyResizer -more advanced IResizeFrame interface ........ sparta: -DockedFormEditor adjustment for latest changes in mdi package -small changes in mdi (visibility of methods). -OnModified method for IResizeFrame ........ sparta: MDI -simulate MDI forms order for TMultiplyResizer -property DesignedForm: IDesignedForm for IResizeFrame ........ sparta: -IMPORTANT! pixel perfect form resizing (fix for problems for controls with align alLeft, alRight etc on design form). -Fix problem for windows: wrong design design window width (a little bigger than designed size) TFormImpl.SetRealBounds -> AdjustSize ........ sparta: mdi bug fix for AV in TMultiplyResizer ........ Fix compilation for FPC 3.0 (TRect changes in FPC 3.1 trunk) ........ sparta: Cannot resize the docked form designer, issue #29380 patch from Anthony Walter. Thanks! ........ sparta ToolsAPI: Delphi compatible ToolsAPI/DesignIDE interface at XE2 level (proxy for IDEIntf). Initial commit (no functionality yet), just interfaces and classes without implementation: designeditors.pas: -TComponentEditor designintf.pas: -Interfaces: IEventInfo, IClass, IActivatable, IDesignObject, IDesignPersistent, IDesignerSelections, IDesigner60, IDesigner70, IDesigner80, IDesigner100, IDesigner, IComponentEditor -TBaseComponentEditor -RegisterComponentEditor designmenus.pas: -Interfaces: IMenuItems, IMenu, IMainMenu, IPopupMenu, IMenuItem ........ when form is removed we need to remove all handlers located in collections FFormsStack and FForms. Necessary to avoid AV. ........ sparta: more correct and simpler calculation of form border for Windows ........ sparta: * Fix for loop error for resize. Highly visible problem for docked forms/frames with Align=alClient. * New THookFrame class as new meta class for Frames. ........ updated lpl ........ git-svn-id: trunk@52728 -
916 lines
24 KiB
ObjectPascal
916 lines
24 KiB
ObjectPascal
{
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 2014 by Maciej Izak (hnb)
|
|
member of the Free Sparta development team (http://freesparta.com)
|
|
|
|
Copyright(c) 2004-2014 DaThoX
|
|
|
|
It contains the Free Pascal generics library
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************}
|
|
|
|
unit Generics.Hashes;
|
|
|
|
{$MODE DELPHI}{$H+}
|
|
{$POINTERMATH ON}
|
|
{$MACRO ON}
|
|
{$COPERATORS ON}
|
|
{$OVERFLOWCHECKS OFF}
|
|
{$RANGECHECKS OFF}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils;
|
|
|
|
// Original version of Bob Jenkins Hash
|
|
// http://burtleburtle.net/bob/c/lookup3.c
|
|
function HashWord(
|
|
AKey: PLongWord; //* the key, an array of uint32_t values */
|
|
ALength: SizeInt; //* the length of the key, in uint32_ts */
|
|
AInitVal: UInt32): UInt32; //* the previous hash, or an arbitrary value */
|
|
procedure HashWord2 (
|
|
AKey: PLongWord; //* the key, an array of uint32_t values */
|
|
ALength: SizeInt; //* the length of the key, in uint32_ts */
|
|
var APrimaryHashAndInitVal: UInt32; //* IN: seed OUT: primary hash value */
|
|
var ASecondaryHashAndInitVal: UInt32); //* IN: more seed OUT: secondary hash value */
|
|
|
|
function HashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): UInt32;
|
|
procedure HashLittle2(
|
|
AKey: Pointer; //* the key to hash */
|
|
ALength: SizeInt; //* length of the key */
|
|
var APrimaryHashAndInitVal: UInt32; //* IN: primary initval, OUT: primary hash */
|
|
var ASecondaryHashAndInitVal: UInt32); //* IN: secondary initval, OUT: secondary hash */
|
|
|
|
function DelphiHashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): Int32;
|
|
procedure DelphiHashLittle2(AKey: Pointer; ALength: SizeInt; var APrimaryHashAndInitVal, ASecondaryHashAndInitVal: UInt32);
|
|
|
|
// hash function from fstl
|
|
function SimpleChecksumHash(AKey: Pointer; ALength: SizeInt): UInt32;
|
|
|
|
// some other hashes
|
|
// http://stackoverflow.com/questions/14409466/simple-hash-functions
|
|
// http://www.partow.net/programming/hashfunctions/
|
|
// http://en.wikipedia.org/wiki/List_of_hash_functions
|
|
// http://www.cse.yorku.ca/~oz/hash.html
|
|
|
|
// https://code.google.com/p/hedgewars/source/browse/hedgewars/adler32.pas
|
|
function Adler32(AKey: Pointer; ALength: SizeInt): UInt32;
|
|
function sdbm(AKey: Pointer; ALength: SizeInt): UInt32;
|
|
|
|
implementation
|
|
|
|
function SimpleChecksumHash(AKey: Pointer; ALength: SizeInt): UInt32;
|
|
var
|
|
i: Integer;
|
|
ABuffer: PUInt8 absolute AKey;
|
|
begin
|
|
Result := 0;
|
|
for i := 0 to ALength - 1 do
|
|
Inc(Result,ABuffer[i]);
|
|
end;
|
|
|
|
function Adler32(AKey: Pointer; ALength: SizeInt): UInt32;
|
|
const
|
|
MOD_ADLER = 65521;
|
|
var
|
|
ABuffer: PUInt8 absolute AKey;
|
|
a: UInt32 = 1;
|
|
b: UInt32 = 0;
|
|
n: Integer;
|
|
begin
|
|
for n := 0 to ALength -1 do
|
|
begin
|
|
a := (a + ABuffer[n]) mod MOD_ADLER;
|
|
b := (b + a) mod MOD_ADLER;
|
|
end;
|
|
Result := (b shl 16) or a;
|
|
end;
|
|
|
|
function sdbm(AKey: Pointer; ALength: SizeInt): UInt32;
|
|
var
|
|
c: PUInt8 absolute AKey;
|
|
i: Integer;
|
|
begin
|
|
Result := 0;
|
|
c := AKey;
|
|
for i := 0 to ALength - 1 do
|
|
begin
|
|
Result := c^ + (Result shl 6) + (Result shl 16) {%H-}- Result;
|
|
Inc(c);
|
|
end;
|
|
end;
|
|
|
|
{ BobJenkinsHash }
|
|
|
|
{$define mix_abc :=
|
|
a -= c; a := a xor (((c)shl(4)) or ((c)shr(32-(4)))); c += b;
|
|
b -= a; b := b xor (((a)shl(6)) or ((a)shr(32-(6)))); a += c;
|
|
c -= b; c := c xor (((b)shl(8)) or ((b)shr(32-(8)))); b += a;
|
|
a -= c; a := a xor (((c)shl(16)) or ((c)shr(32-(16)))); c += b;
|
|
b -= a; b := b xor (((a)shl(19)) or ((a)shr(32-(19)))); a += c;
|
|
c -= b; c := c xor (((b)shl(4)) or ((b)shr(32-(4)))); b += a
|
|
}
|
|
|
|
{$define final_abc :=
|
|
c := c xor b; c -= (((b)shl(14)) or ((b)shr(32-(14))));
|
|
a := a xor c; a -= (((c)shl(11)) or ((c)shr(32-(11))));
|
|
b := b xor a; b -= (((a)shl(25)) or ((a)shr(32-(25))));
|
|
c := c xor b; c -= (((b)shl(16)) or ((b)shr(32-(16))));
|
|
a := a xor c; a -= (((c)shl(4)) or ((c)shr(32-(4))));
|
|
b := b xor a; b -= (((a)shl(14)) or ((a)shr(32-(14))));
|
|
c := c xor b; c -= (((b)shl(24)) or ((b)shr(32-(24))))
|
|
}
|
|
|
|
function HashWord(
|
|
AKey: PLongWord; //* the key, an array of uint32_t values */
|
|
ALength: SizeInt; //* the length of the key, in uint32_ts */
|
|
AInitVal: UInt32): UInt32; //* the previous hash, or an arbitrary value */
|
|
var
|
|
a,b,c: UInt32;
|
|
label
|
|
Case0, Case1, Case2, Case3;
|
|
begin
|
|
//* Set up the internal state */
|
|
a := $DEADBEEF + (UInt32(ALength) shl 2) + AInitVal;
|
|
b := a;
|
|
c := b;
|
|
|
|
//*------------------------------------------------- handle most of the key */
|
|
while ALength > 3 do
|
|
begin
|
|
a += AKey[0];
|
|
b += AKey[1];
|
|
c += AKey[2];
|
|
mix_abc;
|
|
ALength -= 3;
|
|
AKey += 3;
|
|
end;
|
|
|
|
//*------------------------------------------- handle the last 3 uint32_t's */
|
|
case ALength of //* all the case statements fall through */
|
|
3: goto Case3;
|
|
2: goto Case2;
|
|
1: goto Case1;
|
|
0: goto Case0;
|
|
end;
|
|
Case3: c+=AKey[2];
|
|
Case2: b+=AKey[1];
|
|
Case1: a+=AKey[0];
|
|
final_abc;
|
|
Case0: //* case 0: nothing left to add */
|
|
//*------------------------------------------------------ report the result */
|
|
Result := c;
|
|
end;
|
|
|
|
procedure HashWord2 (
|
|
AKey: PLongWord; //* the key, an array of uint32_t values */
|
|
ALength: SizeInt; //* the length of the key, in uint32_ts */
|
|
var APrimaryHashAndInitVal: UInt32; //* IN: seed OUT: primary hash value */
|
|
var ASecondaryHashAndInitVal: UInt32); //* IN: more seed OUT: secondary hash value */
|
|
var
|
|
a,b,c: UInt32;
|
|
label
|
|
Case0, Case1, Case2, Case3;
|
|
begin
|
|
//* Set up the internal state */
|
|
a := $deadbeef + (UInt32(ALength shl 2)) + APrimaryHashAndInitVal;
|
|
b := a;
|
|
c := b;
|
|
c += ASecondaryHashAndInitVal;
|
|
|
|
//*------------------------------------------------- handle most of the key */
|
|
while ALength > 3 do
|
|
begin
|
|
a += AKey[0];
|
|
b += AKey[1];
|
|
c += AKey[2];
|
|
mix_abc;
|
|
ALength -= 3;
|
|
AKey += 3;
|
|
end;
|
|
|
|
//*------------------------------------------- handle the last 3 uint32_t's */
|
|
case ALength of //* all the case statements fall through */
|
|
3: goto Case3;
|
|
2: goto Case2;
|
|
1: goto Case1;
|
|
0: goto Case0;
|
|
end;
|
|
Case3: c+=AKey[2];
|
|
Case2: b+=AKey[1];
|
|
Case1: a+=AKey[0];
|
|
final_abc;
|
|
Case0: //* case 0: nothing left to add */
|
|
//*------------------------------------------------------ report the result */
|
|
APrimaryHashAndInitVal := c;
|
|
ASecondaryHashAndInitVal := b;
|
|
end;
|
|
|
|
function HashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): UInt32;
|
|
var
|
|
a, b, c: UInt32;
|
|
u: record case byte of
|
|
0: (ptr: Pointer);
|
|
1: (i: PtrUint);
|
|
end absolute AKey;
|
|
|
|
k32: ^UInt32 absolute AKey;
|
|
k16: ^UInt16 absolute AKey;
|
|
k8: ^UInt8 absolute AKey;
|
|
|
|
label _10, _8, _6, _4, _2;
|
|
label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
|
|
|
|
begin
|
|
a := $DEADBEEF + UInt32(ALength) + AInitVal;
|
|
b := a;
|
|
c := b;
|
|
|
|
{$IFDEF ENDIAN_LITTLE}
|
|
if (u.i and $3) = 0 then
|
|
begin
|
|
while (ALength > 12) do
|
|
begin
|
|
a += k32[0];
|
|
b += k32[1];
|
|
c += k32[2];
|
|
mix_abc;
|
|
ALength -= 12;
|
|
k32 += 3;
|
|
end;
|
|
|
|
case ALength of
|
|
12: begin c += k32[2]; b += k32[1]; a += k32[0]; end;
|
|
11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end;
|
|
10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end;
|
|
9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end;
|
|
8 : begin b += k32[1]; a += k32[0]; end;
|
|
7 : begin b += k32[1] and $ffffff; a += k32[0]; end;
|
|
6 : begin b += k32[1] and $ffff; a += k32[0]; end;
|
|
5 : begin b += k32[1] and $ff; a += k32[0]; end;
|
|
4 : begin a += k32[0]; end;
|
|
3 : begin a += k32[0] and $ffffff; end;
|
|
2 : begin a += k32[0] and $ffff; end;
|
|
1 : begin a += k32[0] and $ff; end;
|
|
0 : Exit(c); // zero length strings require no mixing
|
|
end
|
|
end
|
|
else
|
|
if (u.i and $1) = 0 then
|
|
begin
|
|
while (ALength > 12) do
|
|
begin
|
|
a += k16[0] + (UInt32(k16[1]) shl 16);
|
|
b += k16[2] + (UInt32(k16[3]) shl 16);
|
|
c += k16[4] + (UInt32(k16[5]) shl 16);
|
|
mix_abc;
|
|
ALength -= 12;
|
|
k16 += 6;
|
|
end;
|
|
|
|
case ALength of
|
|
12:
|
|
begin
|
|
c+=k16[4]+((UInt32(k16[5])) shl 16);
|
|
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
|
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
|
end;
|
|
11:
|
|
begin
|
|
c+=(UInt32(k8[10])) shl 16; //* fall through */
|
|
goto _10;
|
|
end;
|
|
10:
|
|
begin _10:
|
|
c+=k16[4];
|
|
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
|
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
|
end;
|
|
9 :
|
|
begin
|
|
c+=k8[8]; //* fall through */
|
|
goto _8;
|
|
end;
|
|
8 :
|
|
begin _8:
|
|
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
|
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
|
end;
|
|
7 :
|
|
begin
|
|
b+=(UInt32(k8[6])) shl 16; //* fall through */
|
|
goto _6;
|
|
end;
|
|
6 :
|
|
begin _6:
|
|
b+=k16[2];
|
|
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
|
end;
|
|
5 :
|
|
begin
|
|
b+=k8[4]; //* fall through */
|
|
goto _4;
|
|
end;
|
|
4 :
|
|
begin _4:
|
|
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
|
end;
|
|
3 :
|
|
begin
|
|
a+=(UInt32(k8[2])) shl 16; //* fall through */
|
|
goto _2;
|
|
end;
|
|
2 :
|
|
begin _2:
|
|
a+=k16[0];
|
|
end;
|
|
1 :
|
|
begin
|
|
a+=k8[0];
|
|
end;
|
|
0 : Exit(c); //* zero length requires no mixing */
|
|
end;
|
|
end
|
|
else
|
|
{$ENDIF}
|
|
begin
|
|
while ALength > 12 do
|
|
begin
|
|
a += k8[0];
|
|
a += (UInt32(k8[1])) shl 8;
|
|
a += (UInt32(k8[2])) shl 16;
|
|
a += (UInt32(k8[3])) shl 24;
|
|
b += k8[4];
|
|
b += (UInt32(k8[5])) shl 8;
|
|
b += (UInt32(k8[6])) shl 16;
|
|
b += (UInt32(k8[7])) shl 24;
|
|
c += k8[8];
|
|
c += (UInt32(k8[9])) shl 8;
|
|
c += (UInt32(k8[10])) shl 16;
|
|
c += (UInt32(k8[11])) shl 24;
|
|
mix_abc;
|
|
ALength -= 12;
|
|
k8 += 12;
|
|
end;
|
|
|
|
case ALength of
|
|
12: goto Case12;
|
|
11: goto Case11;
|
|
10: goto Case10;
|
|
9 : goto Case9;
|
|
8 : goto Case8;
|
|
7 : goto Case7;
|
|
6 : goto Case6;
|
|
5 : goto Case5;
|
|
4 : goto Case4;
|
|
3 : goto Case3;
|
|
2 : goto Case2;
|
|
1 : goto Case1;
|
|
0 : Exit(c);
|
|
end;
|
|
|
|
Case12: c+=(UInt32(k8[11])) shl 24;
|
|
Case11: c+=(UInt32(k8[10])) shl 16;
|
|
Case10: c+=(UInt32(k8[9])) shl 8;
|
|
Case9: c+=k8[8];
|
|
Case8: b+=(UInt32(k8[7])) shl 24;
|
|
Case7: b+=(UInt32(k8[6])) shl 16;
|
|
Case6: b+=(UInt32(k8[5])) shl 8;
|
|
Case5: b+=k8[4];
|
|
Case4: a+=(UInt32(k8[3])) shl 24;
|
|
Case3: a+=(UInt32(k8[2])) shl 16;
|
|
Case2: a+=(UInt32(k8[1])) shl 8;
|
|
Case1: a+=k8[0];
|
|
end;
|
|
|
|
final_abc;
|
|
Result := c;
|
|
end;
|
|
|
|
(*
|
|
* hashlittle2: return 2 32-bit hash values
|
|
*
|
|
* This is identical to hashlittle(), except it returns two 32-bit hash
|
|
* values instead of just one. This is good enough for hash table
|
|
* lookup with 2^^64 buckets, or if you want a second hash if you're not
|
|
* happy with the first, or if you want a probably-unique 64-bit ID for
|
|
* the key. *pc is better mixed than *pb, so use *pc first. If you want
|
|
* a 64-bit value do something like "*pc + (((uint64_t)*pb)<<32)".
|
|
*)
|
|
procedure HashLittle2(
|
|
AKey: Pointer; //* the key to hash */
|
|
ALength: SizeInt; //* length of the key */
|
|
var APrimaryHashAndInitVal: UInt32; //* IN: primary initval, OUT: primary hash */
|
|
var ASecondaryHashAndInitVal: UInt32); //* IN: secondary initval, OUT: secondary hash */
|
|
var
|
|
a,b,c: UInt32;
|
|
u: record case byte of
|
|
0: (ptr: Pointer);
|
|
1: (i: PtrUint);
|
|
end absolute AKey;
|
|
|
|
k32: ^UInt32 absolute AKey;
|
|
k16: ^UInt16 absolute AKey;
|
|
k8: ^UInt8 absolute AKey;
|
|
|
|
label _10, _8, _6, _4, _2;
|
|
label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
|
|
|
|
begin
|
|
//* Set up the internal state */
|
|
a := $DEADBEEF + UInt32(ALength) + APrimaryHashAndInitVal;
|
|
b := a;
|
|
c := b;
|
|
c += ASecondaryHashAndInitVal;
|
|
|
|
{$IFDEF ENDIAN_LITTLE}
|
|
if (u.i and $3) = 0 then
|
|
begin
|
|
while (ALength > 12) do
|
|
begin
|
|
a += k32[0];
|
|
b += k32[1];
|
|
c += k32[2];
|
|
mix_abc;
|
|
ALength -= 12;
|
|
k32 += 3;
|
|
end;
|
|
|
|
case ALength of
|
|
12: begin c += k32[2]; b += k32[1]; a += k32[0]; end;
|
|
11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end;
|
|
10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end;
|
|
9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end;
|
|
8 : begin b += k32[1]; a += k32[0]; end;
|
|
7 : begin b += k32[1] and $ffffff; a += k32[0]; end;
|
|
6 : begin b += k32[1] and $ffff; a += k32[0]; end;
|
|
5 : begin b += k32[1] and $ff; a += k32[0]; end;
|
|
4 : begin a += k32[0]; end;
|
|
3 : begin a += k32[0] and $ffffff; end;
|
|
2 : begin a += k32[0] and $ffff; end;
|
|
1 : begin a += k32[0] and $ff; end;
|
|
0 :
|
|
begin
|
|
APrimaryHashAndInitVal := c;
|
|
ASecondaryHashAndInitVal := b;
|
|
Exit; // zero length strings require no mixing
|
|
end;
|
|
end
|
|
end
|
|
else
|
|
if (u.i and $1) = 0 then
|
|
begin
|
|
while (ALength > 12) do
|
|
begin
|
|
a += k16[0] + (UInt32(k16[1]) shl 16);
|
|
b += k16[2] + (UInt32(k16[3]) shl 16);
|
|
c += k16[4] + (UInt32(k16[5]) shl 16);
|
|
mix_abc;
|
|
ALength -= 12;
|
|
k16 += 6;
|
|
end;
|
|
|
|
case ALength of
|
|
12:
|
|
begin
|
|
c+=k16[4]+((UInt32(k16[5])) shl 16);
|
|
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
|
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
|
end;
|
|
11:
|
|
begin
|
|
c+=(UInt32(k8[10])) shl 16; //* fall through */
|
|
goto _10;
|
|
end;
|
|
10:
|
|
begin _10:
|
|
c+=k16[4];
|
|
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
|
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
|
end;
|
|
9 :
|
|
begin
|
|
c+=k8[8]; //* fall through */
|
|
goto _8;
|
|
end;
|
|
8 :
|
|
begin _8:
|
|
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
|
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
|
end;
|
|
7 :
|
|
begin
|
|
b+=(UInt32(k8[6])) shl 16; //* fall through */
|
|
goto _6;
|
|
end;
|
|
6 :
|
|
begin _6:
|
|
b+=k16[2];
|
|
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
|
end;
|
|
5 :
|
|
begin
|
|
b+=k8[4]; //* fall through */
|
|
goto _4;
|
|
end;
|
|
4 :
|
|
begin _4:
|
|
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
|
end;
|
|
3 :
|
|
begin
|
|
a+=(UInt32(k8[2])) shl 16; //* fall through */
|
|
goto _2;
|
|
end;
|
|
2 :
|
|
begin _2:
|
|
a+=k16[0];
|
|
end;
|
|
1 :
|
|
begin
|
|
a+=k8[0];
|
|
end;
|
|
0 :
|
|
begin
|
|
APrimaryHashAndInitVal := c;
|
|
ASecondaryHashAndInitVal := b;
|
|
Exit; // zero length strings require no mixing
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
{$ENDIF}
|
|
begin
|
|
while ALength > 12 do
|
|
begin
|
|
a += k8[0];
|
|
a += (UInt32(k8[1])) shl 8;
|
|
a += (UInt32(k8[2])) shl 16;
|
|
a += (UInt32(k8[3])) shl 24;
|
|
b += k8[4];
|
|
b += (UInt32(k8[5])) shl 8;
|
|
b += (UInt32(k8[6])) shl 16;
|
|
b += (UInt32(k8[7])) shl 24;
|
|
c += k8[8];
|
|
c += (UInt32(k8[9])) shl 8;
|
|
c += (UInt32(k8[10])) shl 16;
|
|
c += (UInt32(k8[11])) shl 24;
|
|
mix_abc;
|
|
ALength -= 12;
|
|
k8 += 12;
|
|
end;
|
|
|
|
case ALength of
|
|
12: goto Case12;
|
|
11: goto Case11;
|
|
10: goto Case10;
|
|
9 : goto Case9;
|
|
8 : goto Case8;
|
|
7 : goto Case7;
|
|
6 : goto Case6;
|
|
5 : goto Case5;
|
|
4 : goto Case4;
|
|
3 : goto Case3;
|
|
2 : goto Case2;
|
|
1 : goto Case1;
|
|
0 :
|
|
begin
|
|
APrimaryHashAndInitVal := c;
|
|
ASecondaryHashAndInitVal := b;
|
|
Exit; // zero length strings require no mixing
|
|
end;
|
|
end;
|
|
|
|
Case12: c+=(UInt32(k8[11])) shl 24;
|
|
Case11: c+=(UInt32(k8[10])) shl 16;
|
|
Case10: c+=(UInt32(k8[9])) shl 8;
|
|
Case9: c+=k8[8];
|
|
Case8: b+=(UInt32(k8[7])) shl 24;
|
|
Case7: b+=(UInt32(k8[6])) shl 16;
|
|
Case6: b+=(UInt32(k8[5])) shl 8;
|
|
Case5: b+=k8[4];
|
|
Case4: a+=(UInt32(k8[3])) shl 24;
|
|
Case3: a+=(UInt32(k8[2])) shl 16;
|
|
Case2: a+=(UInt32(k8[1])) shl 8;
|
|
Case1: a+=k8[0];
|
|
end;
|
|
|
|
final_abc;
|
|
APrimaryHashAndInitVal := c;
|
|
ASecondaryHashAndInitVal := b;
|
|
end;
|
|
|
|
procedure DelphiHashLittle2(AKey: Pointer; ALength: SizeInt; var APrimaryHashAndInitVal, ASecondaryHashAndInitVal: UInt32);
|
|
var
|
|
a,b,c: UInt32;
|
|
u: record case byte of
|
|
0: (ptr: Pointer);
|
|
1: (i: PtrUint);
|
|
end absolute AKey;
|
|
|
|
k32: ^UInt32 absolute AKey;
|
|
k16: ^UInt16 absolute AKey;
|
|
k8: ^UInt8 absolute AKey;
|
|
|
|
label _10, _8, _6, _4, _2;
|
|
label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
|
|
|
|
begin
|
|
//* Set up the internal state */
|
|
a := $DEADBEEF + UInt32(ALength shl 2) + APrimaryHashAndInitVal; // delphi version bug? original version don't have "shl 2"
|
|
b := a;
|
|
c := b;
|
|
c += ASecondaryHashAndInitVal;
|
|
|
|
{$IFDEF ENDIAN_LITTLE}
|
|
if (u.i and $3) = 0 then
|
|
begin
|
|
while (ALength > 12) do
|
|
begin
|
|
a += k32[0];
|
|
b += k32[1];
|
|
c += k32[2];
|
|
mix_abc;
|
|
ALength -= 12;
|
|
k32 += 3;
|
|
end;
|
|
|
|
case ALength of
|
|
12: begin c += k32[2]; b += k32[1]; a += k32[0]; end;
|
|
11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end;
|
|
10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end;
|
|
9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end;
|
|
8 : begin b += k32[1]; a += k32[0]; end;
|
|
7 : begin b += k32[1] and $ffffff; a += k32[0]; end;
|
|
6 : begin b += k32[1] and $ffff; a += k32[0]; end;
|
|
5 : begin b += k32[1] and $ff; a += k32[0]; end;
|
|
4 : begin a += k32[0]; end;
|
|
3 : begin a += k32[0] and $ffffff; end;
|
|
2 : begin a += k32[0] and $ffff; end;
|
|
1 : begin a += k32[0] and $ff; end;
|
|
0 :
|
|
begin
|
|
APrimaryHashAndInitVal := c;
|
|
ASecondaryHashAndInitVal := b;
|
|
Exit; // zero length strings require no mixing
|
|
end;
|
|
end
|
|
end
|
|
else
|
|
if (u.i and $1) = 0 then
|
|
begin
|
|
while (ALength > 12) do
|
|
begin
|
|
a += k16[0] + (UInt32(k16[1]) shl 16);
|
|
b += k16[2] + (UInt32(k16[3]) shl 16);
|
|
c += k16[4] + (UInt32(k16[5]) shl 16);
|
|
mix_abc;
|
|
ALength -= 12;
|
|
k16 += 6;
|
|
end;
|
|
|
|
case ALength of
|
|
12:
|
|
begin
|
|
c+=k16[4]+((UInt32(k16[5])) shl 16);
|
|
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
|
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
|
end;
|
|
11:
|
|
begin
|
|
c+=(UInt32(k8[10])) shl 16; //* fall through */
|
|
goto _10;
|
|
end;
|
|
10:
|
|
begin _10:
|
|
c+=k16[4];
|
|
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
|
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
|
end;
|
|
9 :
|
|
begin
|
|
c+=k8[8]; //* fall through */
|
|
goto _8;
|
|
end;
|
|
8 :
|
|
begin _8:
|
|
b+=k16[2]+((UInt32(k16[3])) shl 16);
|
|
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
|
end;
|
|
7 :
|
|
begin
|
|
b+=(UInt32(k8[6])) shl 16; //* fall through */
|
|
goto _6;
|
|
end;
|
|
6 :
|
|
begin _6:
|
|
b+=k16[2];
|
|
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
|
end;
|
|
5 :
|
|
begin
|
|
b+=k8[4]; //* fall through */
|
|
goto _4;
|
|
end;
|
|
4 :
|
|
begin _4:
|
|
a+=k16[0]+((UInt32(k16[1])) shl 16);
|
|
end;
|
|
3 :
|
|
begin
|
|
a+=(UInt32(k8[2])) shl 16; //* fall through */
|
|
goto _2;
|
|
end;
|
|
2 :
|
|
begin _2:
|
|
a+=k16[0];
|
|
end;
|
|
1 :
|
|
begin
|
|
a+=k8[0];
|
|
end;
|
|
0 :
|
|
begin
|
|
APrimaryHashAndInitVal := c;
|
|
ASecondaryHashAndInitVal := b;
|
|
Exit; // zero length strings require no mixing
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
{$ENDIF}
|
|
begin
|
|
while ALength > 12 do
|
|
begin
|
|
a += k8[0];
|
|
a += (UInt32(k8[1])) shl 8;
|
|
a += (UInt32(k8[2])) shl 16;
|
|
a += (UInt32(k8[3])) shl 24;
|
|
b += k8[4];
|
|
b += (UInt32(k8[5])) shl 8;
|
|
b += (UInt32(k8[6])) shl 16;
|
|
b += (UInt32(k8[7])) shl 24;
|
|
c += k8[8];
|
|
c += (UInt32(k8[9])) shl 8;
|
|
c += (UInt32(k8[10])) shl 16;
|
|
c += (UInt32(k8[11])) shl 24;
|
|
mix_abc;
|
|
ALength -= 12;
|
|
k8 += 12;
|
|
end;
|
|
|
|
case ALength of
|
|
12: goto Case12;
|
|
11: goto Case11;
|
|
10: goto Case10;
|
|
9 : goto Case9;
|
|
8 : goto Case8;
|
|
7 : goto Case7;
|
|
6 : goto Case6;
|
|
5 : goto Case5;
|
|
4 : goto Case4;
|
|
3 : goto Case3;
|
|
2 : goto Case2;
|
|
1 : goto Case1;
|
|
0 :
|
|
begin
|
|
APrimaryHashAndInitVal := c;
|
|
ASecondaryHashAndInitVal := b;
|
|
Exit; // zero length strings require no mixing
|
|
end;
|
|
end;
|
|
|
|
Case12: c+=(UInt32(k8[11])) shl 24;
|
|
Case11: c+=(UInt32(k8[10])) shl 16;
|
|
Case10: c+=(UInt32(k8[9])) shl 8;
|
|
Case9: c+=k8[8];
|
|
Case8: b+=(UInt32(k8[7])) shl 24;
|
|
Case7: b+=(UInt32(k8[6])) shl 16;
|
|
Case6: b+=(UInt32(k8[5])) shl 8;
|
|
Case5: b+=k8[4];
|
|
Case4: a+=(UInt32(k8[3])) shl 24;
|
|
Case3: a+=(UInt32(k8[2])) shl 16;
|
|
Case2: a+=(UInt32(k8[1])) shl 8;
|
|
Case1: a+=k8[0];
|
|
end;
|
|
|
|
final_abc;
|
|
APrimaryHashAndInitVal := c;
|
|
ASecondaryHashAndInitVal := b;
|
|
end;
|
|
|
|
function DelphiHashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): Int32;
|
|
var
|
|
a, b, c: UInt32;
|
|
u: record case byte of
|
|
0: (ptr: Pointer);
|
|
1: (i: PtrUint);
|
|
end absolute AKey;
|
|
|
|
k32: ^UInt32 absolute AKey;
|
|
//k16: ^UInt16 absolute AKey;
|
|
k8: ^UInt8 absolute AKey;
|
|
|
|
label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
|
|
|
|
begin
|
|
a := $DEADBEEF + UInt32(ALength shl 2) + AInitVal; // delphi version bug? original version don't have "shl 2"
|
|
b := a;
|
|
c := b;
|
|
|
|
{.$IFDEF ENDIAN_LITTLE} // Delphi version don't care
|
|
if (u.i and $3) = 0 then
|
|
begin
|
|
while (ALength > 12) do
|
|
begin
|
|
a += k32[0];
|
|
b += k32[1];
|
|
c += k32[2];
|
|
mix_abc;
|
|
ALength -= 12;
|
|
k32 += 3;
|
|
end;
|
|
|
|
case ALength of
|
|
12: begin c += k32[2]; b += k32[1]; a += k32[0]; end;
|
|
11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end;
|
|
10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end;
|
|
9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end;
|
|
8 : begin b += k32[1]; a += k32[0]; end;
|
|
7 : begin b += k32[1] and $ffffff; a += k32[0]; end;
|
|
6 : begin b += k32[1] and $ffff; a += k32[0]; end;
|
|
5 : begin b += k32[1] and $ff; a += k32[0]; end;
|
|
4 : begin a += k32[0]; end;
|
|
3 : begin a += k32[0] and $ffffff; end;
|
|
2 : begin a += k32[0] and $ffff; end;
|
|
1 : begin a += k32[0] and $ff; end;
|
|
0 : Exit(c); // zero length strings require no mixing
|
|
end
|
|
end
|
|
else
|
|
{.$ENDIF}
|
|
begin
|
|
while ALength > 12 do
|
|
begin
|
|
a += k8[0];
|
|
a += (UInt32(k8[1])) shl 8;
|
|
a += (UInt32(k8[2])) shl 16;
|
|
a += (UInt32(k8[3])) shl 24;
|
|
b += k8[4];
|
|
b += (UInt32(k8[5])) shl 8;
|
|
b += (UInt32(k8[6])) shl 16;
|
|
b += (UInt32(k8[7])) shl 24;
|
|
c += k8[8];
|
|
c += (UInt32(k8[9])) shl 8;
|
|
c += (UInt32(k8[10])) shl 16;
|
|
c += (UInt32(k8[11])) shl 24;
|
|
mix_abc;
|
|
ALength -= 12;
|
|
k8 += 12;
|
|
end;
|
|
|
|
case ALength of
|
|
12: goto Case12;
|
|
11: goto Case11;
|
|
10: goto Case10;
|
|
9 : goto Case9;
|
|
8 : goto Case8;
|
|
7 : goto Case7;
|
|
6 : goto Case6;
|
|
5 : goto Case5;
|
|
4 : goto Case4;
|
|
3 : goto Case3;
|
|
2 : goto Case2;
|
|
1 : goto Case1;
|
|
0 : Exit(c);
|
|
end;
|
|
|
|
Case12: c+=(UInt32(k8[11])) shl 24;
|
|
Case11: c+=(UInt32(k8[10])) shl 16;
|
|
Case10: c+=(UInt32(k8[9])) shl 8;
|
|
Case9: c+=k8[8];
|
|
Case8: b+=(UInt32(k8[7])) shl 24;
|
|
Case7: b+=(UInt32(k8[6])) shl 16;
|
|
Case6: b+=(UInt32(k8[5])) shl 8;
|
|
Case5: b+=k8[4];
|
|
Case4: a+=(UInt32(k8[3])) shl 24;
|
|
Case3: a+=(UInt32(k8[2])) shl 16;
|
|
Case2: a+=(UInt32(k8[1])) shl 8;
|
|
Case1: a+=k8[0];
|
|
end;
|
|
|
|
final_abc;
|
|
Result := Int32(c);
|
|
end;
|
|
|
|
end.
|
|
|