diff --git a/components/sparta/generics/source/inc/generics.dictionaries.inc b/components/sparta/generics/source/inc/generics.dictionaries.inc deleted file mode 100644 index 8405648346..0000000000 --- a/components/sparta/generics/source/inc/generics.dictionaries.inc +++ /dev/null @@ -1,2269 +0,0 @@ -{%MainUnit generics.collections.pas} - -{ - 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. - - Acknowledgment - - Thanks to Sphere 10 Software (http://sphere10.com) for sponsoring - many new types and major refactoring of entire library - - Thanks to mORMot (http://synopse.info) project for the best implementations - of hashing functions like crc32c and xxHash32 :) - - **********************************************************************} - -{ TPair } - -class function TPair.Create(AKey: TKey; - AValue: TValue): TPair; -begin - Result.Key := AKey; - Result.Value := AValue; -end; - -{ TCustomDictionary } - -procedure TCustomDictionary.PairNotify(constref APair: TDictionaryPair; - ACollectionNotification: TCollectionNotification); -begin - KeyNotify(APair.Key, ACollectionNotification); - ValueNotify(APair.Value, ACollectionNotification); -end; - -procedure TCustomDictionary.KeyNotify(constref AKey: TKey; - ACollectionNotification: TCollectionNotification); -begin - if Assigned(FOnKeyNotify) then - FOnKeyNotify(Self, AKey, ACollectionNotification); -end; - -procedure TCustomDictionary.SetValue(var AValue: TValue; constref ANewValue: TValue); -var - LOldValue: TValue; -begin - LOldValue := AValue; - AValue := ANewValue; - - ValueNotify(LOldValue, cnRemoved); - ValueNotify(ANewValue, cnAdded); -end; - -procedure TCustomDictionary.ValueNotify(constref AValue: TValue; - ACollectionNotification: TCollectionNotification); -begin - if Assigned(FOnValueNotify) then - FOnValueNotify(Self, AValue, ACollectionNotification); -end; - -constructor TCustomDictionary.Create; -begin - Create(0); -end; - -constructor TCustomDictionary.Create(ACapacity: SizeInt); overload; -begin - Create(ACapacity, TEqualityComparer.Default(THashFactory)); -end; - -constructor TCustomDictionary.Create(ACapacity: SizeInt; - const AComparer: IEqualityComparer); -begin - FEqualityComparer := AComparer; - SetCapacity(ACapacity); -end; - -constructor TCustomDictionary.Create(const AComparer: IEqualityComparer); -begin - Create(0, AComparer); -end; - -constructor TCustomDictionary.Create(ACollection: TEnumerable); -begin - Create(ACollection, TEqualityComparer.Default(THashFactory)); -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -constructor TCustomDictionary.Create(ACollection: TEnumerableWithPointers); -begin - Create(ACollection, TEqualityComparer.Default(THashFactory)); -end; -{$ENDIF} - -constructor TCustomDictionary.Create(ACollection: TEnumerable; - const AComparer: IEqualityComparer); overload; -var - LItem: TDictionaryPair; -begin - Create(AComparer); - for LItem in ACollection do - Add(LItem); -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -constructor TCustomDictionary.Create(ACollection: TEnumerableWithPointers; - const AComparer: IEqualityComparer); overload; -var - LItem: PDictionaryPair; -begin - Create(AComparer); - for LItem in ACollection.Ptr^ do - Add(LItem^); -end; -{$ENDIF} - -destructor TCustomDictionary.Destroy; -begin - Clear; - FKeys.Free; - FValues.Free; - inherited; -end; - -function TCustomDictionary.ToArray(ACount: SizeInt): TArray; -var - i: SizeInt; - LEnumerator: TEnumerator; -begin - SetLength(Result, ACount); - LEnumerator := DoGetEnumerator; - - i := 0; - while LEnumerator.MoveNext do - begin - Result[i] := LEnumerator.Current; - Inc(i); - end; - LEnumerator.Free; -end; - -function TCustomDictionary.ToArray: TArray; -begin - Result := ToArray(Count); -end; - -{ TCustomDictionaryEnumerator } - -constructor TCustomDictionaryEnumerator.Create( - ADictionary: TCustomDictionary); -begin - inherited Create; - FIndex := -1; - FDictionary := ADictionary; -end; - -function TCustomDictionaryEnumerator.DoGetCurrent: T; -begin - Result := GetCurrent; -end; - -{ TDictionaryEnumerable } - -function TDictionaryEnumerable.GetPtrEnumerator: TEnumerator; -begin - Result := TDictionaryPointersEnumerator.Create(FDictionary); -end; - -constructor TDictionaryEnumerable.Create( - ADictionary: TCustomDictionary); -begin - FDictionary := ADictionary; -end; - -function TDictionaryEnumerable. - DoGetEnumerator: TDictionaryEnumerator; -begin - Result := TDictionaryEnumerator(TDictionaryEnumerator.NewInstance); - TCustomDictionaryEnumerator(Result).Create(FDictionary); -end; - -function TDictionaryEnumerable.GetCount: SizeInt; -begin - Result := TCustomDictionary(FDictionary).Count; -end; - -function TDictionaryEnumerable.ToArray: TArray; -begin - Result := ToArrayImpl(FDictionary.Count); -end; - -{ TOpenAddressingEnumerator } - -function TOpenAddressingEnumerator.DoMoveNext: Boolean; -var - LLength: SizeInt; -begin - Inc(FIndex); - - LLength := Length(TOpenAddressing(FDictionary).FItems); - - if FIndex >= LLength then - Exit(False); - - // maybe related to bug #24098 - // compiler error for (TDictionary(FDictionary).FItems[FIndex].Hash and UInt32.GetSignMask) = 0 - while ((TOpenAddressing(FDictionary).FItems[FIndex].Hash) and UInt32.GetSignMask) = 0 do - begin - Inc(FIndex); - if FIndex = LLength then - Exit(False); - end; - - Result := True; -end; - -{ TOpenAddressingPointersEnumerator } - -function TOpenAddressingPointersEnumerator.DoMoveNext: boolean; -var - LLength: SizeInt; -begin - Inc(FIndex); - - LLength := Length(FItems^); - - if FIndex >= LLength then - Exit(False); - - // maybe related to bug #24098 - // compiler error for (TDictionary(FDictionary).FItems[FIndex].Hash and UInt32.GetSignMask) = 0 - while (FItems^[FIndex].Hash and UInt32.GetSignMask) = 0 do - begin - Inc(FIndex); - if FIndex = LLength then - Exit(False); - end; - - Result := True; -end; - -function TOpenAddressingPointersEnumerator.DoGetCurrent: PDictionaryPair; -begin - Result := GetCurrent; -end; - -function TOpenAddressingPointersEnumerator.GetCurrent: PDictionaryPair; -begin - Result := @FItems^[FIndex].Pair; -end; - -constructor TOpenAddressingPointersEnumerator.Create(var AItems); -begin - FIndex := -1; - FItems := @AItems; -end; - -{ TOpenAddressingPointersCollection } - -function TOpenAddressingPointersCollection.Items: PArray; -begin - Result := PArray(@((@Self)^)); -end; - -function TOpenAddressingPointersCollection.GetCount: SizeInt; -begin - Result := PSizeInt(PByte(@((@Self)^))-SizeOf(SizeInt))^; -end; - -function TOpenAddressingPointersCollection.GetEnumerator: TPointersEnumerator; -begin - Result := TPointersEnumerator(TPointersEnumerator.NewInstance); - TPointersEnumerator(Result).Create(Items^); -end; - -function TOpenAddressingPointersCollection.ToArray: TArray; -{begin - Result := ToArrayImpl(FList.Count); -end;} -var - i: SizeInt; - LEnumerator: TPointersEnumerator; -begin - SetLength(Result, GetCount); - - try - LEnumerator := GetEnumerator; - - i := 0; - while LEnumerator.MoveNext do - begin - Result[i] := LEnumerator.Current; - Inc(i); - end; - finally - LEnumerator.Free; - end; -end; - -{ TOpenAddressing } - -constructor TOpenAddressing.Create(ACapacity: SizeInt; - const AComparer: IEqualityComparer); -begin - inherited Create(ACapacity, AComparer); - - FMaxLoadFactor := TProbeSequence.DEFAULT_LOAD_FACTOR; -end; - -function TOpenAddressing.GetKeys: TKeyCollection; -begin - if not Assigned(FKeys) then - FKeys := TKeyCollection.Create(Self); - Result := TKeyCollection(FKeys); -end; - -function TOpenAddressing.GetValues: TValueCollection; -begin - if not Assigned(FValues) then - FValues := TValueCollection.Create(Self); - Result := TValueCollection(FValues); -end; - -function TOpenAddressing.FindBucketIndex(constref AKey: TKey): SizeInt; -var - LHash: UInt32; -begin - Result := FindBucketIndex(FItems, AKey, LHash); -end; - -procedure TOpenAddressing.PrepareAddingItem; -begin - if RealItemsLength > FItemsThreshold then - Rehash(Length(FItems) shl 1) - else if FItemsThreshold = 0 then - begin - SetLength(FItems, 8); - UpdateItemsThreshold(8); - end - else if FItemsLength = $40000001 then // High(TIndex) ... Error: Type mismatch - OutOfMemoryError; -end; - -procedure TOpenAddressing.UpdateItemsThreshold(ASize: SizeInt); -begin - if ASize = $40000000 then - FItemsThreshold := $40000001 - else - FItemsThreshold := Pred(Round(ASize * FMaxLoadFactor)); -end; - -procedure TOpenAddressing.AddItem(var AItem: TItem; constref AKey: TKey; - constref AValue: TValue; const AHash: UInt32); -begin - AItem.Hash := AHash; - AItem.Pair.Key := AKey; - AItem.Pair.Value := AValue; - - // ! very important. FItemsLength must be increased after above code (because constref has meaning) - Inc(FItemsLength); - - PairNotify(AItem.Pair, cnAdded); -end; - -function TOpenAddressing.GetPointers: PPointersCollection; -begin - Result := PPointersCollection(@FItems); -end; - -procedure TOpenAddressing.Add(constref AKey: TKey; constref AValue: TValue); -begin - DoAdd(AKey, AValue); -end; - -procedure TOpenAddressing.Add(constref APair: TPair); -begin - DoAdd(APair.Key, APair.Value); -end; - -function TOpenAddressing.DoAdd(constref AKey: TKey; constref AValue: TValue): SizeInt; -var - LHash: UInt32; -begin - PrepareAddingItem; - - Result := FindBucketIndex(FItems, AKey, LHash); - if Result >= 0 then - raise EListError.CreateRes(@SDuplicatesNotAllowed); - - Result := not Result; - AddItem(FItems[Result], AKey, AValue, LHash); -end; - -function TOpenAddressing.DoRemove(AIndex: SizeInt; - ACollectionNotification: TCollectionNotification): TValue; -var - LItem: PItem; - LPair: TPair; -begin - LItem := @FItems[AIndex]; - LItem.Hash := 0; - Result := LItem.Pair.Value; - LPair := LItem.Pair; - LItem.Pair := Default(TPair); - Dec(FItemsLength); - PairNotify(LPair, ACollectionNotification); -end; - -procedure TOpenAddressing.Remove(constref AKey: TKey); -var - LIndex: SizeInt; -begin - LIndex := FindBucketIndex(AKey); - if LIndex < 0 then - Exit; - - DoRemove(LIndex, cnRemoved); -end; - -function TOpenAddressing.ExtractPair(constref AKey: TKey): TPair; -var - LIndex: SizeInt; -begin - LIndex := FindBucketIndex(AKey); - if LIndex < 0 then - Exit(Default(TPair)); - - Result.Key := AKey; - Result.Value := DoRemove(LIndex, cnExtracted); -end; - -procedure TOpenAddressing.Clear; -var - LItem: PItem; - i: SizeInt; - LOldItems: array of TItem; -begin - FItemsLength := 0; - FItemsThreshold := 0; - // ClearTombstones; - LOldItems := FItems; - FItems := nil; - - for i := 0 to High(LOldItems) do - begin - LItem := @LOldItems[i]; - if (LItem.Hash and UInt32.GetSignMask = 0) then - Continue; - - PairNotify(LItem.Pair, cnRemoved); - end; -end; - -function TOpenAddressing.RealItemsLength: SizeInt; -begin - Result := FItemsLength; -end; - -function TOpenAddressing.Rehash(ASizePow2: SizeInt; AForce: Boolean): Boolean; -var - LNewItems: TArray; - LHash: UInt32; - LIndex: SizeInt; - i: SizeInt; - LItem, LNewItem: PItem; -begin - if (ASizePow2 = Length(FItems)) and not AForce then - Exit(False); - if ASizePow2 < 0 then - OutOfMemoryError; - - SetLength(LNewItems, ASizePow2); - UpdateItemsThreshold(ASizePow2); - - for i := 0 to High(FItems) do - begin - LItem := @FItems[i]; - - if (LItem.Hash and UInt32.GetSignMask) <> 0 then - begin - LIndex := FindBucketIndex(LNewItems, LItem.Pair.Key, LHash); - LIndex := not LIndex; - - LNewItem := @LNewItems[LIndex]; - LNewItem.Hash := LHash; - LNewItem.Pair := LItem.Pair; - end; - end; - - FItems := LNewItems; - Result := True; -end; - -function TOpenAddressing.DoGetEnumerator: TEnumerator; -begin - Result := GetEnumerator; -end; - -procedure TOpenAddressing.SetCapacity(ACapacity: SizeInt); -begin - if ACapacity < FItemsLength then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - Resize(ACapacity); -end; - -procedure TOpenAddressing.SetMaxLoadFactor(AValue: single); -var - LItemsLength: SizeInt; -begin - if (AValue > TProbeSequence.MAX_LOAD_FACTOR) or (AValue <= 0) then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - FMaxLoadFactor := AValue; - - repeat - LItemsLength := Length(FItems); - UpdateItemsThreshold(LItemsLength); - if RealItemsLength > FItemsThreshold then - Rehash(LItemsLength shl 1); - until RealItemsLength <= FItemsThreshold; -end; - -function TOpenAddressing.GetLoadFactor: single; -begin - Result := FItemsLength / Length(FItems); -end; - -function TOpenAddressing.GetCapacity: SizeInt; -begin - Result := Length(FItems); -end; - -procedure TOpenAddressing.Resize(ANewSize: SizeInt); -var - LNewSize: SizeInt; -begin - if ANewSize < 0 then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - LNewSize := 0; - if ANewSize > 0 then - begin - LNewSize := 8; - while LNewSize < ANewSize do - LNewSize := LNewSize shl 1; - end; - - Rehash(LNewSize); -end; - -function TOpenAddressing.GetEnumerator: TPairEnumerator; -begin - Result := TPairEnumerator.Create(Self); -end; - -function TOpenAddressing.GetItem(const AKey: TKey): TValue; -var - LIndex: SizeInt; -begin - LIndex := FindBucketIndex(AKey); - if LIndex < 0 then - raise EListError.CreateRes(@SDictionaryKeyDoesNotExist); - Result := FItems[LIndex].Pair.Value; -end; - -procedure TOpenAddressing.TrimExcess; -begin - SetCapacity(Succ(FItemsLength)); -end; - -procedure TOpenAddressing.SetItem(const AKey: TKey; const AValue: TValue); -var - LIndex: SizeInt; -begin - LIndex := FindBucketIndex(AKey); - if LIndex < 0 then - raise EListError.CreateRes(@SItemNotFound); - - SetValue(FItems[LIndex].Pair.Value, AValue); -end; - -function TOpenAddressing.TryGetValue(constref AKey: TKey; out AValue: TValue): Boolean; -var - LIndex: SizeInt; -begin - LIndex := FindBucketIndex(AKey); - Result := LIndex >= 0; - - if Result then - AValue := FItems[LIndex].Pair.Value - else - AValue := Default(TValue); -end; - -procedure TOpenAddressing.AddOrSetValue(constref AKey: TKey; constref AValue: TValue); -var - LIndex: SizeInt; - LHash: UInt32; -begin - LIndex := FindBucketIndex(FItems, AKey, LHash); - - if LIndex < 0 then - DoAdd(AKey, AValue) - else - SetValue(FItems[LIndex].Pair.Value, AValue); -end; - -function TOpenAddressing.ContainsKey(constref AKey: TKey): Boolean; -var - LIndex: SizeInt; -begin - LIndex := FindBucketIndex(AKey); - Result := LIndex >= 0; -end; - -function TOpenAddressing.ContainsValue(constref AValue: TValue): Boolean; -begin - Result := ContainsValue(AValue, TEqualityComparer.Default(THashFactory)); -end; - -function TOpenAddressing.ContainsValue(constref AValue: TValue; - const AEqualityComparer: IEqualityComparer): Boolean; -var - i: SizeInt; - LItem: PItem; -begin - if Length(FItems) = 0 then - Exit(False); - - for i := 0 to High(FItems) do - begin - LItem := @FItems[i]; - if (LItem.Hash and UInt32.GetSignMask) = 0 then - Continue; - - if AEqualityComparer.Equals(AValue, LItem.Pair.Value) then - Exit(True); - end; - Result := False; -end; - -procedure TOpenAddressing.GetMemoryLayout( - const AOnGetMemoryLayoutKeyPosition: TOnGetMemoryLayoutKeyPosition); -var - i: SizeInt; -begin - for i := 0 to High(FItems) do - if (FItems[i].Hash and UInt32.GetSignMask) <> 0 then - AOnGetMemoryLayoutKeyPosition(Self, i); -end; - -{ TOpenAddressing.TPairEnumerator } - -function TOpenAddressing.TPairEnumerator.GetCurrent: TPair; -begin - Result := TOpenAddressing(FDictionary).FItems[FIndex].Pair; -end; - -{ TOpenAddressing.TValueEnumerator } - -function TOpenAddressing.TValueEnumerator.GetCurrent: TValue; -begin - Result := TOpenAddressing(FDictionary).FItems[FIndex].Pair.Value; -end; - -{ TOpenAddressing.TPValueEnumerator } - -function TOpenAddressing.TPValueEnumerator.GetCurrent: PValue; -begin - Result := @(TOpenAddressing(FDictionary).FItems[FIndex].Pair.Value); -end; - -{ TOpenAddressing.TKeyEnumerator } - -function TOpenAddressing.TKeyEnumerator.GetCurrent: TKey; -begin - Result := TOpenAddressing(FDictionary).FItems[FIndex].Pair.Key; -end; - -{ TOpenAddressing.TPKeyEnumerator } - -function TOpenAddressing.TPKeyEnumerator.GetCurrent: PKey; -begin - Result := @(TOpenAddressing(FDictionary).FItems[FIndex].Pair.Key); -end; - -{ TOpenAddressingLP } - -procedure TOpenAddressingLP.NotifyIndexChange(AFrom, ATo: SizeInt); -begin -end; - -function TOpenAddressingLP.DoRemove(AIndex: SizeInt; - ACollectionNotification: TCollectionNotification): TValue; -var - LItem: PItem; - LPair: TPair; - LLengthMask: SizeInt; - i, LIndex, LGapIndex: SizeInt; - LHash, LBucket: UInt32; -begin - LItem := @FItems[AIndex]; - LPair := LItem.Pair; - - // try fill gap - LHash := LItem.Hash; - LItem.Hash := 0; // prevents an infinite searching loop - LLengthMask := Length(FItems) - 1; - i := Succ(AIndex - (LHash and LLengthMask)); - LGapIndex := AIndex; - repeat - LIndex := TProbeSequence.Probe(i, LHash) and LLengthMask; - LItem := @FItems[LIndex]; - - // Empty position - if (LItem.Hash and UInt32.GetSignMask) = 0 then - Break; // breaking bad! - - LBucket := LItem.Hash and LLengthMask; - if not InCircularRange(LGapIndex, LBucket, LIndex) then - begin - NotifyIndexChange(LIndex, LGapIndex); - FItems[LGapIndex] := LItem^; - LItem.Hash := 0; // new gap - LGapIndex := LIndex; - end; - Inc(i); - until false; - - LItem := @FItems[LGapIndex]; - LItem.Hash := 0; - LItem.Pair := Default(TPair); - Dec(FItemsLength); - - Result := LPair.Value; - PairNotify(LPair, ACollectionNotification); -end; - -function TOpenAddressingLP.FindBucketIndex(constref AItems: TArray; - constref AKey: TKey; out AHash: UInt32): SizeInt; -var - LItem: {TOpenAddressing.}_TItem; // for workaround Lazarus bug #25613 - LLengthMask: SizeInt; - i, m: SizeInt; - LHash: UInt32; -begin - m := Length(AItems); - LLengthMask := m - 1; - - LHash := FEqualityComparer.GetHashCode(AKey); - - i := 0; - AHash := LHash or UInt32.GetSignMask; - - if m = 0 then - Exit(-1); - - Result := AHash and LLengthMask; - - repeat - LItem := _TItem(AItems[Result]); - - // Empty position - if (LItem.Hash and UInt32.GetSignMask) = 0 then - Exit(not Result); // insert! - - // Same position? - if LItem.Hash = AHash then - if FEqualityComparer.Equals(AKey, LItem.Pair.Key) then - Exit; - - Inc(i); - - Result := TProbeSequence.Probe(i, AHash) and LLengthMask; - - until false; -end; - -{ TOpenAddressingTombstones } - -function TOpenAddressingTombstones.Rehash(ASizePow2: SizeInt; AForce: Boolean): Boolean; -begin - if inherited then - FTombstonesCount := 0; -end; - -function TOpenAddressingTombstones.RealItemsLength: SizeInt; -begin - Result := FItemsLength + FTombstonesCount -end; - -procedure TOpenAddressingTombstones.ClearTombstones; -begin - Rehash(Length(FItems), True); -end; - -procedure TOpenAddressingTombstones.Clear; -begin - FTombstonesCount := 0; - inherited; -end; - -function TOpenAddressingTombstones.DoRemove(AIndex: SizeInt; - ACollectionNotification: TCollectionNotification): TValue; -begin - Result := inherited; - - FItems[AIndex].Hash := 1; - Inc(FTombstonesCount); -end; - -function TOpenAddressingTombstones.DoAdd(constref AKey: TKey; - constref AValue: TValue): SizeInt; -var - LHash: UInt32; -begin - PrepareAddingItem; - - Result := FindBucketIndexOrTombstone(FItems, AKey, LHash); - if Result >= 0 then - raise EListError.CreateRes(@SDuplicatesNotAllowed); - - Result := not Result; - // Can't ovverride because we lost info about old hash - if FItems[Result].Hash <> 0 then - Dec(FTombstonesCount); - - AddItem(FItems[Result], AKey, AValue, LHash); -end; - -{ TOpenAddressingSH } - -function TOpenAddressingSH.FindBucketIndex(constref AItems: TArray; - constref AKey: TKey; out AHash: UInt32): SizeInt; -var - LItem: {TOpenAddressing.}_TItem; // for workaround Lazarus bug #25613 - LLengthMask: SizeInt; - i, m: SizeInt; - LHash: UInt32; -begin - m := Length(AItems); - LLengthMask := m - 1; - - LHash := FEqualityComparer.GetHashCode(AKey); - - i := 0; - AHash := LHash or UInt32.GetSignMask; - - if m = 0 then - Exit(-1); - - Result := AHash and LLengthMask; - - repeat - LItem := _TItem(AItems[Result]); - // Empty position - if LItem.Hash = 0 then - Exit(not Result); // insert! - - // Same position? - if LItem.Hash = AHash then - if FEqualityComparer.Equals(AKey, LItem.Pair.Key) then - Exit; - - Inc(i); - - Result := TProbeSequence.Probe(i, AHash) and LLengthMask; - - until false; -end; - -function TOpenAddressingSH.FindBucketIndexOrTombstone(constref AItems: TArray; - constref AKey: TKey; out AHash: UInt32): SizeInt; -var - LItem: {TOpenAddressing.}_TItem; // for workaround Lazarus bug #25613 - LLengthMask: SizeInt; - i, m: SizeInt; - LHash: UInt32; -begin - m := Length(AItems); - LLengthMask := m - 1; - - LHash := FEqualityComparer.GetHashCode(AKey); - - i := 0; - AHash := LHash or UInt32.GetSignMask; - - if m = 0 then - Exit(-1); - - Result := AHash and LLengthMask; - - repeat - LItem := _TItem(AItems[Result]); - - // Empty position or tombstone - if LItem.Hash and UInt32.GetSignMask = 0 then - Exit(not Result); // insert! - - // Same position? - if LItem.Hash = AHash then - if FEqualityComparer.Equals(AKey, LItem.Pair.Key) then - Exit; - - Inc(i); - - Result := TProbeSequence.Probe(i, AHash) and LLengthMask; - - until false; -end; - -{ TOpenAddressingQP } - -procedure TOpenAddressingQP.UpdateItemsThreshold(ASize: SizeInt); -begin - if ASize = $40000000 then - FItemsThreshold := $40000001 - else - begin - FPrimaryNumberAsSizeApproximation := PrimaryNumbersJustLessThanPowerOfTwo[ - MultiplyDeBruijnBitPosition[UInt32(((ASize and -ASize) * $077CB531)) shr 27]]; - - FItemsThreshold := Pred(Round(FPrimaryNumberAsSizeApproximation * FMaxLoadFactor)); - end; -end; - -function TOpenAddressingQP.FindBucketIndex(constref AItems: TArray; - constref AKey: TKey; out AHash: UInt32): SizeInt; -var - LItem: {TOpenAddressing.}_TItem; // for workaround Lazarus bug #25613 - i: SizeInt; - LHash: UInt32; -begin - LHash := FEqualityComparer.GetHashCode(AKey); - - i := 0; - AHash := LHash or UInt32.GetSignMask; - - if Length(AItems) = 0 then - Exit(-1); - - for i := 0 to FPrimaryNumberAsSizeApproximation - 1 do - begin - Result := TProbeSequence.Probe(i, AHash) mod FPrimaryNumberAsSizeApproximation; - LItem := _TItem(AItems[Result]); - - // Empty position - if LItem.Hash = 0 then - Exit(not Result); // insert! - - // Same position? - if LItem.Hash = AHash then - if FEqualityComparer.Equals(AKey, LItem.Pair.Key) then - Exit; - end; - - Result := -1; -end; - - -function TOpenAddressingQP.FindBucketIndexOrTombstone(constref AItems: TArray; - constref AKey: TKey; out AHash: UInt32): SizeInt; -var - LItem: {TOpenAddressing.}_TItem; // for workaround Lazarus bug #25613 - i: SizeInt; - LHash: UInt32; -begin - LHash := FEqualityComparer.GetHashCode(AKey); - - i := 0; - AHash := LHash or UInt32.GetSignMask; - - if Length(AItems) = 0 then - Exit(-1); - - for i := 0 to FPrimaryNumberAsSizeApproximation - 1 do - begin - Result := TProbeSequence.Probe(i, AHash) mod FPrimaryNumberAsSizeApproximation; - LItem := _TItem(AItems[Result]); - - // Empty position or tombstone - if LItem.Hash and UInt32.GetSignMask = 0 then - Exit(not Result); // insert! - - // Same position? - if LItem.Hash = AHash then - if FEqualityComparer.Equals(AKey, LItem.Pair.Key) then - Exit; - end; - - Result := -1; -end; - -{ TOpenAddressingDH } - -constructor TOpenAddressingDH.Create(ACapacity: SizeInt; - const AComparer: IEqualityComparer); -begin -end; - -constructor TOpenAddressingDH.Create(const AComparer: IEqualityComparer); -begin -end; - -constructor TOpenAddressingDH.Create(ACollection: TEnumerable; - const AComparer: IEqualityComparer); -begin -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -constructor TOpenAddressingDH.Create(ACollection: TEnumerableWithPointers; - const AComparer: IEqualityComparer); -begin -end; -{$ENDIF} - -constructor TOpenAddressingDH.Create(ACapacity: SizeInt); -begin - Create(ACapacity, TExtendedEqualityComparer.Default(THashFactory)); -end; - -constructor TOpenAddressingDH.Create(ACollection: TEnumerable); -begin - Create(ACollection, TExtendedEqualityComparer.Default(THashFactory)); -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -constructor TOpenAddressingDH.Create(ACollection: TEnumerableWithPointers); -begin - Create(ACollection, TExtendedEqualityComparer.Default(THashFactory)); -end; -{$ENDIF} - -constructor TOpenAddressingDH.Create(ACapacity: SizeInt; - const AComparer: IExtendedEqualityComparer); -begin - FMaxLoadFactor := TProbeSequence.DEFAULT_LOAD_FACTOR; - FEqualityComparer := AComparer; - SetCapacity(ACapacity); -end; - -constructor TOpenAddressingDH.Create(const AComparer: IExtendedEqualityComparer); -begin - Create(0, AComparer); -end; - -constructor TOpenAddressingDH.Create(ACollection: TEnumerable; - const AComparer: IExtendedEqualityComparer); -var - LItem: TDictionaryPair; -begin - Create(AComparer); - for LItem in ACollection do - Add(LItem); -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -constructor TOpenAddressingDH.Create(ACollection: TEnumerableWithPointers; - const AComparer: IExtendedEqualityComparer); -var - LItem: PDictionaryPair; -begin - Create(AComparer); - for LItem in ACollection.Ptr^ do - Add(LItem^); -end; -{$ENDIF} - -procedure TOpenAddressingDH.UpdateItemsThreshold(ASize: SizeInt); -begin - inherited; - R := - PrimaryNumbersJustLessThanPowerOfTwo[ - MultiplyDeBruijnBitPosition[UInt32(((ASize and -ASize) * $077CB531)) shr 27]] -end; - -function TOpenAddressingDH.FindBucketIndex(constref AItems: TArray; - constref AKey: TKey; out AHash: UInt32): SizeInt; -var - LItem: {TOpenAddressing.}_TItem; // for workaround Lazarus bug #25613 - LLengthMask: SizeInt; - i, m: SizeInt; - LHash: array[-1..1] of UInt32; - LHash1: UInt32 absolute LHash[0]; - LHash2: UInt32 absolute LHash[1]; -begin - m := Length(AItems); - LLengthMask := m - 1; - LHash[-1] := 2; // number of hashes - - IExtendedEqualityComparer(FEqualityComparer).GetHashList(AKey, @LHash[-1]); - - i := 0; - AHash := LHash1 or UInt32.GetSignMask; - - if m = 0 then - Exit(-1); - - Result := LHash1 and LLengthMask; - // second hash function must be special - LHash2 := (R - (LHash2 mod R)) or 1; - - repeat - LItem := _TItem(AItems[Result]); - - // Empty position - if LItem.Hash = 0 then - Exit(not Result); - - // Same position? - if LItem.Hash = AHash then - if FEqualityComparer.Equals(AKey, LItem.Pair.Key) then - Exit; - - Inc(i); - - Result := TProbeSequence.Probe(i, AHash, LHash2) and LLengthMask; - until false; -end; - -function TOpenAddressingDH.FindBucketIndexOrTombstone(constref AItems: TArray; - constref AKey: TKey; out AHash: UInt32): SizeInt; -var - LItem: {TOpenAddressing.}_TItem; // for workaround Lazarus bug #25613 - LLengthMask: SizeInt; - i, m: SizeInt; - LHash: array[-1..1] of UInt32; - LHash1: UInt32 absolute LHash[0]; - LHash2: UInt32 absolute LHash[1]; -begin - m := Length(AItems); - LLengthMask := m - 1; - LHash[-1] := 2; // number of hashes - - IExtendedEqualityComparer(FEqualityComparer).GetHashList(AKey, @LHash[-1]); - - i := 0; - AHash := LHash1 or UInt32.GetSignMask; - - if m = 0 then - Exit(-1); - - Result := LHash1 and LLengthMask; - // second hash function must be special - LHash2 := (R - (LHash2 mod R)) or 1; - - repeat - LItem := _TItem(AItems[Result]); - - // Empty position or tombstone - if LItem.Hash and UInt32.GetSignMask = 0 then - Exit(not Result); - - // Same position? - if LItem.Hash = AHash then - if FEqualityComparer.Equals(AKey, LItem.Pair.Key) then - Exit; - - Inc(i); - - Result := TProbeSequence.Probe(i, AHash, LHash2) and LLengthMask; - until false; -end; - -{ TDeamortizedDArrayCuckooMapEnumerator } - -constructor TDeamortizedDArrayCuckooMapEnumerator.Create( - ADictionary: TCustomDictionary); -begin - inherited; - if ADictionary.Count = 0 then - FMainIndex := TCuckooCfg.D - else - FMainIndex := 0; -end; - -function TDeamortizedDArrayCuckooMapEnumerator.DoMoveNext: Boolean; -var - LLength: SizeInt; - LArray: TItemsArray; -begin - Inc(FIndex); - - if (FMainIndex = TCuckooCfg.D) then // queue - begin - LLength := Length(TDeamortizedDArrayCuckooMap(FDictionary).FQueue.FItems); - if FIndex >= LLength then - Exit(False); - - while ((TDeamortizedDArrayCuckooMap(FDictionary).FQueue.FItems[FIndex].Hash) - and UInt32.GetSignMask) = 0 do - begin - Inc(FIndex); - if FIndex = LLength then - Exit(False); - end; - end - else // d-array - begin - LArray := TItemsArray(TDeamortizedDArrayCuckooMap(FDictionary).FItems[FMainIndex]); - LLength := Length(LArray); - if FIndex >= LLength then - begin - Inc(FMainIndex); - FIndex := -1; - Exit(DoMoveNext); - end; - - while ((LArray[FIndex].Hash) and UInt32.GetSignMask) = 0 do - begin - Inc(FIndex); - if FIndex = LLength then - begin - Inc(FMainIndex); - FIndex := -1; - Exit(DoMoveNext); - end; - end; - end; - - Result := True; -end; - -{ TDeamortizedDArrayPointersEnumerator } - -function TDeamortizedDArrayPointersEnumerator.DoMoveNext: boolean; -var - LLength: SizeInt; - LArray: TItemsArray; -begin - Inc(FIndex); - - if (FMainIndex = TCuckooCfg.D) then // queue - begin - LLength := Length(FQueue.FItems); - if FIndex >= LLength then - Exit(False); - - while ((FQueue.FItems[FIndex].Hash) - and UInt32.GetSignMask) = 0 do - begin - Inc(FIndex); - if FIndex = LLength then - Exit(False); - end; - end - else // d-array - begin - LArray := FItems^[FMainIndex]; - LLength := Length(LArray); - if FIndex >= LLength then - begin - Inc(FMainIndex); - FIndex := -1; - Exit(DoMoveNext); - end; - - while (((LArray[FIndex]).Hash) and UInt32.GetSignMask) = 0 do - begin - Inc(FIndex); - if FIndex = LLength then - begin - Inc(FMainIndex); - FIndex := -1; - Exit(DoMoveNext); - end; - end; - end; - - Result := True; -end; - -function TDeamortizedDArrayPointersEnumerator.DoGetCurrent: PDictionaryPair; -begin - Result := GetCurrent; -end; - -function TDeamortizedDArrayPointersEnumerator.GetCurrent: PDictionaryPair; -begin - if FMainIndex = TCuckooCfg.D then - Result := @(FQueue.FItems[FIndex].Pair.Value.Pair) - else - Result := @((FItems^[FMainIndex])[FIndex].Pair); -end; - -constructor TDeamortizedDArrayPointersEnumerator.Create(var AItems; AQueue: TQueueDictionary; ACount: SizeInt); -begin - FIndex := -1; - if ACount = 0 then - FMainIndex := TCuckooCfg.D - else - FMainIndex := 0; - FQueue := AQueue; - FItems := @AItems; -end; - -{ TDeamortizedDArrayPointersCollection } - -function TDeamortizedDArrayPointersCollection.Items: PArray; -begin - Result := PArray(@((@Self)^)); -end; - -function TDeamortizedDArrayPointersCollection.GetCount: SizeInt; -begin - Result := SizeInt((@PByte(@((@Self)^))[-SizeOf(SizeInt)])^); -end; - -function TDeamortizedDArrayPointersCollection.GetQueue: TQueueDictionary; -begin - Result := TQueueDictionary((@PByte(@((@Self)^))[SizeOf(TItemsDArray)])^); -end; - -function TDeamortizedDArrayPointersCollection.GetEnumerator: TPointersEnumerator; -begin - Result := TPointersEnumerator(TPointersEnumerator.NewInstance); - TPointersEnumerator(Result).Create(Items^, GetQueue, GetCount); -end; - -function TDeamortizedDArrayPointersCollection.ToArray: TArray; -{begin - Result := ToArrayImpl(FList.Count); -end;} -var - i: SizeInt; - LEnumerator: TPointersEnumerator; -begin - SetLength(Result, GetCount); - - try - LEnumerator := GetEnumerator; - - i := 0; - while LEnumerator.MoveNext do - begin - Result[i] := LEnumerator.Current; - Inc(i); - end; - finally - LEnumerator.Free; - end; -end; - -{ TDeamortizedDArrayCuckooMap } - -function TDeamortizedDArrayCuckooMap.TQueueDictionary.Rehash(ASizePow2: SizeInt; - AForce: boolean): Boolean; -var - FOldIdx: array of TKey; - i: SizeInt; -begin - SetLength(FOldIdx, FIdx.Count); - for i := 0 to FIdx.Count - 1 do - FOldIdx[i] := FItems[FIdx[i]].Pair.Key; - - Result := inherited Rehash(ASizePow2, AForce); - - for i := 0 to FIdx.Count - 1 do - FIdx[i] := FindBucketIndex(FOldIdx[i]); -end; - -procedure TDeamortizedDArrayCuckooMap.TQueueDictionary.NotifyIndexChange(AFrom, ATo: SizeInt); -var - i: SizeInt; -begin - // notify change position - for i := 0 to FIdx.Count-1 do - if FIdx[i] = AFrom then - begin - FIdx[i] := ATo; - Exit; - end; -end; - -procedure TDeamortizedDArrayCuckooMap.TQueueDictionary.InsertIntoBack(AItem: Pointer); -//var -// LItem: TDeamortizedDArrayCuckooMap.PItem; absolute AItem; !!! bug #25917 -var - LItem: TQueueDictionary.PValue absolute AItem; - LIndex: SizeInt; -begin - LIndex := DoAdd(LItem.Pair.Key, LItem^); - FIdx.Insert(0, LIndex); -end; - -procedure TDeamortizedDArrayCuckooMap.TQueueDictionary.InsertIntoHead(AItem: Pointer); -//var -// LItem: TDeamortizedDArrayCuckooMap.PItem absolute AItem; !!! bug #25917 -var - LItem: TQueueDictionary.PValue absolute AItem; - LIndex: SizeInt; -begin - LIndex := DoAdd(LItem.Pair.Key, LItem^); - FIdx.Add(LIndex); -end; - -function TDeamortizedDArrayCuckooMap.TQueueDictionary.IsEmpty: Boolean; -begin - Result := FIdx.Count = 0; -end; - -function TDeamortizedDArrayCuckooMap.TQueueDictionary.Pop: Pointer; -var - AIndex: SizeInt; - //LResult: TDeamortizedDArrayCuckooMap.TItem; !!!bug #25917 -begin - AIndex := FIdx.DoRemove(FIdx.Count - 1, cnExtracted); - - Result := New(TQueueDictionary.PValue); - TQueueDictionary.PValue(Result)^ := DoRemove(AIndex, cnExtracted); -end; - -constructor TDeamortizedDArrayCuckooMap.TQueueDictionary.Create(ACapacity: SizeInt; - const AComparer: IEqualityComparer); -begin - FIdx := TList.Create; - inherited Create(ACapacity, AComparer); -end; - -destructor TDeamortizedDArrayCuckooMap.TQueueDictionary.Destroy; -begin - FIdx.Free; -end; - -function TDeamortizedDArrayCuckooMap.GetQueueCount: SizeInt; -begin - Result := FQueue.Count; -end; - -constructor TDeamortizedDArrayCuckooMap.Create(ACapacity: SizeInt; - const AComparer: IEqualityComparer); -begin -end; - -constructor TDeamortizedDArrayCuckooMap.Create(const AComparer: IEqualityComparer); -begin -end; - -constructor TDeamortizedDArrayCuckooMap.Create(ACollection: TEnumerable; - const AComparer: IEqualityComparer); -begin -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -constructor TDeamortizedDArrayCuckooMap.Create(ACollection: TEnumerableWithPointers; - const AComparer: IEqualityComparer); -begin -end; -{$ENDIF} - -constructor TDeamortizedDArrayCuckooMap.Create; -begin - Create(0); -end; - -constructor TDeamortizedDArrayCuckooMap.Create(ACapacity: SizeInt); -begin - Create(ACapacity, TExtendedEqualityComparer.Default(THashFactory)); -end; - -constructor TDeamortizedDArrayCuckooMap.Create(ACollection: TEnumerable); -begin - Create(ACollection, TExtendedEqualityComparer.Default(THashFactory)); -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -constructor TDeamortizedDArrayCuckooMap.Create(ACollection: TEnumerableWithPointers); -begin - Create(ACollection, TExtendedEqualityComparer.Default(THashFactory)); -end; -{$ENDIF} - -constructor TDeamortizedDArrayCuckooMap.Create(ACapacity: SizeInt; - const AComparer: IExtendedEqualityComparer); -begin - FMaxLoadFactor := TCuckooCfg.MAX_LOAD_FACTOR; - FQueue := TQueueDictionary.Create; - FCDM := TCDM.Create; - - // to do - check constraint consts - - if TCuckooCfg.D > THashFactory.MAX_HASHLIST_COUNT then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - // should be moved to class constructor, but bug #24848 - CUCKOO_SIGN := UInt32.GetSizedSignMask(THashFactory.HASH_FUNCTIONS_MASK_SIZE + 1); - CUCKOO_INDEX_SIZE := UInt32.GetBitsLength - (THashFactory.HASH_FUNCTIONS_MASK_SIZE + 1); - CUCKOO_HASH_SIGN := THashFactory.HASH_FUNCTIONS_MASK shl CUCKOO_INDEX_SIZE; - - FEqualityComparer := AComparer; - SetCapacity(ACapacity); -end; - -constructor TDeamortizedDArrayCuckooMap.Create(const AComparer: IExtendedEqualityComparer); -begin - Create(0, AComparer); -end; - -constructor TDeamortizedDArrayCuckooMap.Create(ACollection: TEnumerable; - const AComparer: IExtendedEqualityComparer); -var - LItem: TDictionaryPair; -begin - Create(AComparer); - for LItem in ACollection do - Add(LItem); -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -constructor TDeamortizedDArrayCuckooMap.Create(ACollection: TEnumerableWithPointers; - const AComparer: IExtendedEqualityComparer); -var - LItem: PDictionaryPair; -begin - Create(AComparer); - for LItem in ACollection.Ptr^ do - Add(LItem^); -end; -{$ENDIF} - -destructor TDeamortizedDArrayCuckooMap.Destroy; -begin - inherited; - FQueue.Free; - FCDM.Free; -end; - -function TDeamortizedDArrayCuckooMap.GetKeys: TKeyCollection; -begin - if not Assigned(FKeys) then - FKeys := TKeyCollection.Create(Self); - Result := TKeyCollection(FKeys); -end; - -function TDeamortizedDArrayCuckooMap.GetValues: TValueCollection; -begin - if not Assigned(FValues) then - FValues := TValueCollection.Create(Self); - Result := TValueCollection(FValues); -end; - -function TDeamortizedDArrayCuckooMap.GetPointers: PPointersCollection; -begin - Result := PPointersCollection(@FItems); -end; - -function TDeamortizedDArrayCuckooMap.Lookup(constref AKey: TKey; - var AHashListOrIndex: PUInt32): SizeInt; -begin - Result := Lookup(FItems, AKey, AHashListOrIndex); -end; - -function TDeamortizedDArrayCuckooMap.Lookup(constref AItems: TItemsDArray; constref AKey: TKey; - var AHashListOrIndex: PUInt32): SizeInt; -var - LLengthMask: SizeInt; - i, j, k: SizeInt; - AHashList: PUInt32 absolute AHashListOrIndex; - AHashListParams: PUInt16 absolute AHashListOrIndex; - AIndex: PtrInt absolute AHashListOrIndex; - // LBloomFilter: UInt32; // to rethink. now is useless -begin - if Length(AItems[0]) = 0 then - Exit(LR_NIL); - - LLengthMask := Length(AItems[0]) - 1; - AHashListParams[0] := TCuckooCfg.D; // number of hashes - - i := 1; // ineks iteracji iteracji haszy - k := 1; // indeks iteracji haszy - // LBloomFilter := 0; - repeat - AHashListParams[1] := i; // iteration - IExtendedEqualityComparer(FEqualityComparer).GetHashList(AKey, AHashList); - for j := 0 to THashFactory.HASHLIST_COUNT_PER_FUNCTION[i] - 1 do - begin - AHashList[k] := AHashList[k] or CUCKOO_SIGN; - // LBloomFilter := LBloomFilter or AHashList[k]; - - with AItems[k-1][AHashList[k] and LLengthMask] do - if (Hash and UInt32.GetSignMask) <> 0 then - if (AHashList[k] = Hash or CUCKOO_SIGN) and FEqualityComparer.Equals(AKey, Pair.Key) then - Exit(k-1); - - Inc(k); - end; - Inc(i); - until k > TCuckooCfg.D; - - i := FQueue.FindBucketIndex(AKey); - if i >= 0 then - begin - AIndex := i; - Exit(LR_QUEUE); - end; - -{ LBloomFilter := not LBloomFilter; - for i := 0 to FDicQueueList.Count - 1 do - // with FQueue[i] do - if LBloomFilter and FQueue[i].Hash = 0 then - for j := 1 to TCuckooCfg.D do - if (FQueue[i].Hash or CUCKOO_SIGN = AHashList[j]) then - if FEqualityComparer.Equals(AKey, FQueue[i].Pair.Key) then - begin - AIndex := i; - Exit(LR_QUEUE); - end; } - - Result := LR_NIL; -end; - -procedure TDeamortizedDArrayCuckooMap.PrepareAddingItem; -var - i: SizeInt; -begin - if FItemsLength > FItemsThreshold then - Rehash(Length(FItems[0]) shl 1) - else if FItemsThreshold = 0 then - begin - for i := 0 to TCuckooCfg.D - 1 do - SetLength(FItems[i], 4); - UpdateItemsThreshold(4); - end - else if FItemsLength = $40000001 then // High(TIndex) ... Error: Type mismatch - OutOfMemoryError; -end; - -procedure TDeamortizedDArrayCuckooMap.UpdateItemsThreshold(ASize: SizeInt); -var - LLength: SizeInt; -begin - LLength := ASize*TCuckooCfg.D; - if LLength = $40000000 then - FItemsThreshold := $40000001 - else - FItemsThreshold := Pred(Round(LLength * FMaxLoadFactor)); -end; - -procedure TDeamortizedDArrayCuckooMap.AddItem(constref AItems: TItemsDArray; constref AKey: TKey; - constref AValue: TValue; const AHashList: PUInt32); -var - LNewItem: TItem; - LPNewItem: PItem; - y: boolean = false; - b: UInt32; - LIndex: UInt32; - i, LLengthMask: SizeInt; - LTempItem: TItem; - LHashList: array[0..1] of UInt32; - LHashListParams: array[0..3] of UInt16 absolute LHashList; -begin - LLengthMask := Length(AItems[0]) - 1; - - LNewItem.Pair.Key := AKey; - LNewItem.Pair.Value := AValue; - // by concept already sign bit is set - LNewItem.Hash := ((not CUCKOO_HASH_SIGN) and AHashList[1]) or UInt32.GetSignMask; // start at array [0] - FQueue.InsertIntoBack(@LNewItem); - - for i := 0 to TCuckooCfg.L - 1 do - begin - if not y then - if FQueue.IsEmpty then - Exit - else - begin - LPNewItem := FQueue.Pop; // bug #25917 workaround - LNewItem := LPNewItem^; - Dispose(LPNewItem); - b := (LNewItem.Hash and CUCKOO_HASH_SIGN) shr CUCKOO_INDEX_SIZE; - y := true; - end; - LIndex := LNewItem.Hash and LLengthMask; - if (AItems[b][LIndex].Hash and UInt32.GetSignMask) = 0 then // insert! - begin - AItems[b][LIndex] := LNewItem; - FCDM.Clear; - y := false; - end - else - begin - if FCDM.ContainsKey(LNewItem.Pair.Key) then // found second cycle - begin - FQueue.InsertIntoBack(@LNewItem); - FCDM.Clear; - y := false; - end - else - begin - LTempItem := AItems[b][LIndex]; - AItems[b][LIndex] := LNewItem; - LNewItem.Hash := LNewItem.Hash or CUCKOO_SIGN; - FCDM.AddOrSetValue(LNewItem.Pair.Key, EmptyRecord); - - LNewItem := LTempItem; - b := b + 1; - if b >= TCuckooCfg.D then - b := 0; - LHashListParams[0] := -Succ(b); - IExtendedEqualityComparer(FEqualityComparer).GetHashList(LNewItem.Pair.Key, @LHashList[0]); - LNewItem.Hash := (LHashList[1] and not CUCKOO_SIGN) or (b shl CUCKOO_INDEX_SIZE) or UInt32.GetSignMask; - // y := True; // always true in this place - end; - end; - end; - if y then - FQueue.InsertIntoHead(@LNewItem); -end; - -procedure TDeamortizedDArrayCuckooMap.DoAdd(const AKey: TKey; const AValue: TValue; - const AHashList: PUInt32); -begin - AddItem(FItems, AKey, AValue, AHashList); - Inc(FItemsLength); - KeyNotify(AKey, cnAdded); - ValueNotify(AValue, cnAdded); -end; - -procedure TDeamortizedDArrayCuckooMap.Add(constref AKey: TKey; constref AValue: TValue); -var - LHashList: array[0..TCuckooCfg.D] of UInt32; - LHashListOrIndex: PUint32; -begin - PrepareAddingItem; - LHashListOrIndex := @LHashList[0]; - if Lookup(AKey, LHashListOrIndex) <> LR_NIL then - raise EListError.CreateRes(@SDuplicatesNotAllowed); - - DoAdd(AKey, AValue, LHashListOrIndex); -end; - -procedure TDeamortizedDArrayCuckooMap.Add(constref APair: TPair); -begin - Add(APair.Key, APair.Value); -end; - -function TDeamortizedDArrayCuckooMap.DoRemove(const AHashListOrIndex: PUInt32; - ALookupResult: SizeInt; ACollectionNotification: TCollectionNotification): TValue; -var - LItem: PItem; - LIndex: UInt32; - LQueueIndex: SizeInt absolute AHashListOrIndex; - LPair: TPair; -begin - case ALookupResult of - LR_QUEUE: - LPair := FQueue.FItems[LQueueIndex].Pair.Value.Pair; - LR_NIL: - raise ERangeError.Create(SItemNotFound); - else - LIndex := AHashListOrIndex[ALookupResult + 1] and (Length(FItems[0]) - 1); - LItem := @FItems[ALookupResult][LIndex]; - LItem.Hash := 0; - LPair := LItem.Pair; - LItem.Pair := Default(TPair); - end; - - Result := LPair.Value; - Dec(FItemsLength); - if ALookupResult = LR_QUEUE then - begin - FQueue.FIdx.Remove(LQueueIndex); - FQueue.DoRemove(LQueueIndex, cnRemoved); - end; - - FCDM.Remove(LPair.Key); // item can exist in CDM - - PairNotify(LPair, ACollectionNotification); -end; - -procedure TDeamortizedDArrayCuckooMap.Remove(constref AKey: TKey); -var - LHashList: array[0..TCuckooCfg.D] of UInt32; - LHashListOrIndex: PUint32; - LLookupResult: SizeInt; -begin - LHashListOrIndex := @LHashList[0]; - LLookupResult := Lookup(AKey, LHashListOrIndex); - if LLookupResult = LR_NIL then - Exit; - - DoRemove(LHashListOrIndex, LLookupResult, cnRemoved); -end; - -function TDeamortizedDArrayCuckooMap.ExtractPair(constref AKey: TKey): TPair; -var - LHashList: array[0..TCuckooCfg.D] of UInt32; - LHashListOrIndex: PUint32; - LLookupResult: SizeInt; -begin - LHashListOrIndex := @LHashList[0]; - LLookupResult := Lookup(AKey, LHashListOrIndex); - if LLookupResult = LR_NIL then - Exit(Default(TPair)); - - Result.Key := AKey; - Result.Value := DoRemove(LHashListOrIndex, LLookupResult, cnExtracted); -end; - -procedure TDeamortizedDArrayCuckooMap.Clear; -var - LItem: PItem; - i, j: SizeInt; - LOldItems: TItemsDArray; - LOldQueueItems: TQueueDictionary.TItemsArray; - LQueueItem: TQueueDictionary._TItem; -begin - FItemsLength := 0; - FItemsThreshold := 0; - LOldItems := FItems; - for i := 0 to TCuckooCfg.D - 1 do - FItems[i] := nil; - - for i := 0 to TCuckooCfg.D - 1 do - begin - for j := 0 to High(LOldItems[0]) do - begin - LItem := @LOldItems[i][j]; - if (LItem.Hash and UInt32.GetSignMask <> 0) then - PairNotify(LItem.Pair, cnRemoved); - end; - end; - - FCDM.Clear; - - // queue - FQueue.FItemsLength := 0; - FQueue.FItemsThreshold := 0; - LOldQueueItems := FQueue.FItems; - FQueue.FItems := nil; - - for i := 0 to High(LOldQueueItems) do - begin - LQueueItem := TQueueDictionary._TItem(LOldQueueItems[i]); - if (LQueueItem.Hash and UInt32.GetSignMask = 0) then - Continue; - - PairNotify(LQueueItem.Pair.Value.Pair, cnRemoved); - end; -end; - -procedure TDeamortizedDArrayCuckooMap.Rehash(ASizePow2: SizeInt); -var - LNewItems: TItemsDArray; - i, j: SizeInt; - LItem: PItem; - LOldQueue: TQueueDictionary; -var - LHashList: array[0..1] of UInt32; - LHashListParams: array[0..3] of Int16 absolute LHashList; -begin - if ASizePow2 = Length(FItems[0]) then - Exit; - if ASizePow2 < 0 then - OutOfMemoryError; - - for i := 0 to TCuckooCfg.D - 1 do - SetLength(LNewItems[i], ASizePow2); - - LHashListParams[0] := -1; - - // opportunity to clear the queue - LOldQueue := FQueue; - FCDM.Clear; - FQueue := TQueueDictionary.Create; - for i := 0 to LOldQueue.FIdx.Count - 1 do - begin - LItem := @LOldQueue.FItems[LOldQueue.FIdx[i]].Pair.Value; - LHashList[1] := FEqualityComparer.GetHashCode(LItem.Pair.Key); - AddItem(LNewItems, LItem.Pair.Key, LItem.Pair.Value, @LHashList[0]); - end; - LOldQueue.Free; - - // copy the old elements - for i := 0 to TCuckooCfg.D - 1 do - for j := 0 to High(FItems[0]) do - begin - LItem := @FItems[i][j]; - if (LItem.Hash and UInt32.GetSignMask) = 0 then - Continue; - - // small optimization. most of items exist in table 0 - if LItem.Hash and CUCKOO_HASH_SIGN = 0 then - begin - LHashList[1] := LItem.Hash; - AddItem(LNewItems, LItem.Pair.Key, LItem.Pair.Value, @LHashList[0]); - end - else - begin - LHashList[1] := FEqualityComparer.GetHashCode(LItem.Pair.Key); - AddItem(LNewItems, LItem.Pair.Key, LItem.Pair.Value, @LHashList[0]); - end; - end; - - FItems := LNewItems; - UpdateItemsThreshold(ASizePow2); -end; - -function TDeamortizedDArrayCuckooMap.DoGetEnumerator: TEnumerator; -begin - Result := GetEnumerator; -end; - -procedure TDeamortizedDArrayCuckooMap.SetCapacity(ACapacity: SizeInt); -begin - if ACapacity < FItemsLength then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - Resize(ACapacity); -end; - -procedure TDeamortizedDArrayCuckooMap.SetMaxLoadFactor(AValue: single); -var - LItemsLength: SizeInt; -begin - if (AValue > TCuckooCfg.MAX_LOAD_FACTOR) or (AValue <= 0) then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - FMaxLoadFactor := AValue; - - repeat - LItemsLength := Length(FItems[0]); - UpdateItemsThreshold(LItemsLength); - if FItemsLength > FItemsThreshold then - Rehash(LItemsLength shl 1); - until FItemsLength <= FItemsThreshold; -end; - -function TDeamortizedDArrayCuckooMap.GetLoadFactor: single; -begin - Result := FItemsLength / (Length(FItems[0]) * TCuckooCfg.D); -end; - -function TDeamortizedDArrayCuckooMap.GetCapacity: SizeInt; -begin - Result := Length(FItems[0]) * TCuckooCfg.D; -end; - -procedure TDeamortizedDArrayCuckooMap.Resize(ANewSize: SizeInt); -var - LNewSize: SizeInt; -begin - if ANewSize < 0 then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - LNewSize := 0; - if ANewSize > 0 then - begin - LNewSize := 4; - while LNewSize * TCuckooCfg.D < ANewSize do - LNewSize := LNewSize shl 1; - end; - - Rehash(LNewSize); -end; - -function TDeamortizedDArrayCuckooMap.GetEnumerator: TPairEnumerator; -begin - Result := TPairEnumerator.Create(Self); -end; - -function TDeamortizedDArrayCuckooMap.GetItem(const AKey: TKey): TValue; -var - LHashList: array[0..TCuckooCfg.D] of UInt32; - LHashListOrIndex: PUint32; - LLookupResult: SizeInt; - LIndex: UInt32; -begin - LHashListOrIndex := @LHashList[0]; - LLookupResult := Lookup(AKey, LHashListOrIndex); - - case LLookupResult of - LR_QUEUE: - Result := FQueue.FItems[PtrInt(LHashListOrIndex)].Pair.Value.Pair.Value; - LR_NIL: - raise EListError.CreateRes(@SDictionaryKeyDoesNotExist); - else - LIndex := LHashListOrIndex[LLookupResult + 1] and (Length(FItems[0]) - 1); - Result := FItems[LLookupResult][LIndex].Pair.Value; - end; -end; - -procedure TDeamortizedDArrayCuckooMap.TrimExcess; -begin - SetCapacity(Succ(FItemsLength)); - FQueue.TrimExcess; - FQueue.FIdx.TrimExcess; -end; - -procedure TDeamortizedDArrayCuckooMap.SetItem(constref AValue: TValue; - const AHashListOrIndex: PUInt32; ALookupResult: SizeInt); -var - LIndex: UInt32; -begin - case ALookupResult of - LR_QUEUE: - SetValue(FQueue.FItems[PtrInt(AHashListOrIndex)].Pair.Value.Pair.Value, AValue); - LR_NIL: - raise EListError.CreateRes(@SItemNotFound); - else - LIndex := AHashListOrIndex[ALookupResult + 1] and (Length(FItems[0]) - 1); - SetValue(FItems[ALookupResult][LIndex].Pair.Value, AValue); - end; -end; - -procedure TDeamortizedDArrayCuckooMap.SetItem(const AKey: TKey; const AValue: TValue); -var - LHashList: array[0..TCuckooCfg.D] of UInt32; - LHashListOrIndex: PUint32; - LLookupResult: SizeInt; -begin - LHashListOrIndex := @LHashList[0]; - LLookupResult := Lookup(AKey, LHashListOrIndex); - - SetItem(AValue, LHashListOrIndex, LLookupResult); -end; - -function TDeamortizedDArrayCuckooMap.TryGetValue(constref AKey: TKey; out AValue: TValue): Boolean; -var - LHashList: array[0..TCuckooCfg.D] of UInt32; - LHashListOrIndex: PUint32; - LLookupResult: SizeInt; - LIndex: UInt32; -begin - LHashListOrIndex := @LHashList[0]; - LLookupResult := Lookup(AKey, LHashListOrIndex); - - Result := LLookupResult <> LR_NIL; - - case LLookupResult of - LR_QUEUE: - AValue := FQueue.FItems[PtrInt(LHashListOrIndex)].Pair.Value.Pair.Value; - LR_NIL: - AValue := Default(TValue); - else - LIndex := LHashListOrIndex[LLookupResult + 1] and (Length(FItems[0]) - 1); - AValue := FItems[LLookupResult][LIndex].Pair.Value; - end; -end; - -procedure TDeamortizedDArrayCuckooMap.AddOrSetValue(constref AKey: TKey; constref AValue: TValue); -var - LHashList: array[0..TCuckooCfg.D] of UInt32; - LHashListOrIndex: PUint32; - LLookupResult: SizeInt; -begin - LHashListOrIndex := @LHashList[0]; - LLookupResult := Lookup(AKey, LHashListOrIndex); - - if LLookupResult = LR_NIL then - Add(AKey, AValue) - // more optimal version for AddOrSetValue has some bug : see Test_CuckooD2_Notification - //begin - // PrepareAddingItem; - // DoAdd(AKey, AValue, LHashListOrIndex); - //end - else - SetItem(AValue, LHashListOrIndex, LLookupResult); -end; - -function TDeamortizedDArrayCuckooMap.ContainsKey(constref AKey: TKey): Boolean; -var - LHashList: array[0..TCuckooCfg.D] of UInt32; - LHashListOrIndex: PUint32; -begin - LHashListOrIndex := @LHashList[0]; - Result := Lookup(AKey, LHashListOrIndex) <> LR_NIL; -end; - -function TDeamortizedDArrayCuckooMap.ContainsValue(constref AValue: TValue): Boolean; -begin - Result := ContainsValue(AValue, TEqualityComparer.Default(THashFactory)); -end; - -function TDeamortizedDArrayCuckooMap.ContainsValue(constref AValue: TValue; - const AEqualityComparer: IEqualityComparer): Boolean; -var - i, j: SizeInt; - LItem: PItem; -begin - if Length(FItems[0]) = 0 then - Exit(False); - - for i := 0 to TCuckooCfg.D - 1 do - for j := 0 to High(FItems[0]) do - begin - LItem := @FItems[i][j]; - if (LItem.Hash and UInt32.GetSignMask) = 0 then - Continue; - - if AEqualityComparer.Equals(AValue, LItem.Pair.Value) then - Exit(True); - end; - Result := False; -end; - -procedure TDeamortizedDArrayCuckooMap.GetMemoryLayout( - const AOnGetMemoryLayoutKeyPosition: TOnGetMemoryLayoutKeyPosition); -var - i, j, k: SizeInt; -begin - k := 0; - for i := 0 to TCuckooCfg.D - 1 do - for j := 0 to High(FItems[0]) do - begin - if FItems[i][j].Hash and UInt32.GetSignMask <> 0 then - AOnGetMemoryLayoutKeyPosition(Self, k); - inc(k); - end; -end; - -{ TDeamortizedDArrayCuckooMap.TPairEnumerator } - -function TDeamortizedDArrayCuckooMap.TPairEnumerator.GetCurrent: TPair; -begin - if FMainIndex = TCuckooCfg.D then - Result := TDeamortizedDArrayCuckooMap(FDictionary).FQueue.FItems[FIndex].Pair.Value.Pair - else - Result := TDeamortizedDArrayCuckooMap(FDictionary).FItems[FMainIndex][FIndex].Pair; -end; - -{ TDeamortizedDArrayCuckooMap.TValueEnumerator } - -function TDeamortizedDArrayCuckooMap.TValueEnumerator.GetCurrent: TValue; -begin - if FMainIndex = TCuckooCfg.D then - Result := TDeamortizedDArrayCuckooMap(FDictionary).FQueue.FItems[FIndex].Pair.Value.Pair.Value - else - Result := TDeamortizedDArrayCuckooMap(FDictionary).FItems[FMainIndex][FIndex].Pair.Value; -end; - -{ TDeamortizedDArrayCuckooMap.TPValueEnumerator } - -function TDeamortizedDArrayCuckooMap.TPValueEnumerator.GetCurrent: PValue; -begin - if FMainIndex = TCuckooCfg.D then - Result := @(TDeamortizedDArrayCuckooMap(FDictionary).FQueue.FItems[FIndex].Pair.Value.Pair.Value) - else - Result := @(TDeamortizedDArrayCuckooMap(FDictionary).FItems[FMainIndex][FIndex].Pair.Value); -end; - -{ TDeamortizedDArrayCuckooMap.TKeyEnumerator } - -function TDeamortizedDArrayCuckooMap.TKeyEnumerator.GetCurrent: TKey; -begin - if FMainIndex = TCuckooCfg.D then - Result := TDeamortizedDArrayCuckooMap(FDictionary).FQueue.FItems[FIndex].Pair.Value.Pair.Key - else - Result := TDeamortizedDArrayCuckooMap(FDictionary).FItems[FMainIndex][FIndex].Pair.Key; -end; - -{ TDeamortizedDArrayCuckooMap.TPKeyEnumerator } - -function TDeamortizedDArrayCuckooMap.TPKeyEnumerator.GetCurrent: TKey; -begin - if FMainIndex = TCuckooCfg.D then - Result := @(TDeamortizedDArrayCuckooMap(FDictionary).FQueue.FItems[FIndex].Pair.Value.Pair.Key) - else - Result := @(TDeamortizedDArrayCuckooMap(FDictionary).FItems[FMainIndex][FIndex].Pair.Key); -end; - -{ TObjectDictionary } - -procedure TObjectDeamortizedDArrayCuckooMap.KeyNotify( - constref AKey: TKey; ACollectionNotification: TCollectionNotification); -begin - inherited; - - if (doOwnsKeys in FOwnerships) and (ACollectionNotification = cnRemoved) then - TObject((@AKey)^).Free; -end; - -procedure TObjectDeamortizedDArrayCuckooMap.ValueNotify(constref AValue: TValue; - ACollectionNotification: TCollectionNotification); -begin - inherited; - - if (doOwnsValues in FOwnerships) and (ACollectionNotification = cnRemoved) then - TObject((@AValue)^).Free; -end; - -constructor TObjectDeamortizedDArrayCuckooMap.Create( - AOwnerships: TDictionaryOwnerships); -begin - Create(AOwnerships, 0); -end; - -constructor TObjectDeamortizedDArrayCuckooMap.Create( - AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt); -begin - inherited Create(ACapacity); - - FOwnerships := AOwnerships; -end; - -constructor TObjectDeamortizedDArrayCuckooMap.Create( - AOwnerships: TDictionaryOwnerships; const AComparer: IExtendedEqualityComparer); -begin - inherited Create(AComparer); - - FOwnerships := AOwnerships; -end; - -constructor TObjectDeamortizedDArrayCuckooMap.Create( - AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt; const AComparer: IExtendedEqualityComparer); -begin - inherited Create(ACapacity, AComparer); - - FOwnerships := AOwnerships; -end; - -procedure TObjectOpenAddressingLP.KeyNotify( - constref AKey: TKey; ACollectionNotification: TCollectionNotification); -begin - inherited; - - if (doOwnsKeys in FOwnerships) and (ACollectionNotification = cnRemoved) then - TObject((@AKey)^).Free; -end; - -procedure TObjectOpenAddressingLP.ValueNotify( - constref AValue: TValue; ACollectionNotification: TCollectionNotification); -begin - inherited; - - if (doOwnsValues in FOwnerships) and (ACollectionNotification = cnRemoved) then - TObject((@AValue)^).Free; -end; - -constructor TObjectOpenAddressingLP.Create(AOwnerships: TDictionaryOwnerships); -begin - Create(AOwnerships, 0); -end; - -constructor TObjectOpenAddressingLP.Create(AOwnerships: TDictionaryOwnerships; - ACapacity: SizeInt); -begin - inherited Create(ACapacity); - - FOwnerships := AOwnerships; -end; - -constructor TObjectOpenAddressingLP.Create(AOwnerships: TDictionaryOwnerships; - const AComparer: IEqualityComparer); -begin - inherited Create(AComparer); - - FOwnerships := AOwnerships; -end; - -constructor TObjectOpenAddressingLP.Create(AOwnerships: TDictionaryOwnerships; - ACapacity: SizeInt; const AComparer: IEqualityComparer); -begin - inherited Create(ACapacity, AComparer); - - FOwnerships := AOwnerships; -end; diff --git a/components/sparta/generics/source/inc/generics.dictionariesh.inc b/components/sparta/generics/source/inc/generics.dictionariesh.inc deleted file mode 100644 index e0a66db66a..0000000000 --- a/components/sparta/generics/source/inc/generics.dictionariesh.inc +++ /dev/null @@ -1,655 +0,0 @@ -{%MainUnit generics.collections.pas} - -{ - 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. - - Acknowledgment - - Thanks to Sphere 10 Software (http://sphere10.com) for sponsoring - many new types and major refactoring of entire library - - Thanks to mORMot (http://synopse.info) project for the best implementations - of hashing functions like crc32c and xxHash32 :) - - **********************************************************************} - -{$WARNINGS OFF} -type - TEmptyRecord = record // special record for Dictionary TValue (Dictionary as Set) - end; - - { TPair } - - TPair = record - public - Key: TKey; - Value: TValue; - class function Create(AKey: TKey; AValue: TValue): TPair; static; - end; - - { TCustomDictionary } - - // bug #24283 and #24097 (forward declaration) - should be: - // TCustomDictionary = class(TEnumerable >); - TCustomDictionary = class abstract - public type - // workaround... no generics types in generics types - TDictionaryPair = TPair; - PDictionaryPair = ^TDictionaryPair; - PKey = ^TKey; - PValue = ^TValue; - THashFactoryClass = THashFactory; - protected - FEqualityComparer: IEqualityComparer; - FKeys: TEnumerable; - FValues: TEnumerable; - FMaxLoadFactor: single; - protected - procedure SetCapacity(ACapacity: SizeInt); virtual; abstract; - // bug #24283. workaround for this class because can't inherit from TEnumerable - function DoGetEnumerator: TEnumerator; virtual; abstract; {override;} - - procedure SetMaxLoadFactor(AValue: single); virtual; abstract; - function GetLoadFactor: single; virtual; abstract; - function GetCapacity: SizeInt; virtual; abstract; - public - property MaxLoadFactor: single read FMaxLoadFactor write SetMaxLoadFactor; - property LoadFactor: single read GetLoadFactor; - property Capacity: SizeInt read GetCapacity write SetCapacity; - - procedure Clear; virtual; abstract; - procedure Add(constref APair: TPair); virtual; abstract; - strict private // bug #24283. workaround for this class because can't inherit from TEnumerable - function ToArray(ACount: SizeInt): TArray; overload; - public - function ToArray: TArray; virtual; final; {override; final; // bug #24283} overload; - - constructor Create; virtual; overload; - constructor Create(ACapacity: SizeInt); virtual; overload; - constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer); virtual; overload; - constructor Create(const AComparer: IEqualityComparer); overload; - constructor Create(ACollection: TEnumerable); virtual; overload; - constructor Create(ACollection: TEnumerable; const AComparer: IEqualityComparer); virtual; overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - constructor Create(ACollection: TEnumerableWithPointers); virtual; overload; - constructor Create(ACollection: TEnumerableWithPointers; const AComparer: IEqualityComparer); virtual; overload; - {$ENDIF} - - destructor Destroy; override; - private - FOnKeyNotify: TCollectionNotifyEvent; - FOnValueNotify: TCollectionNotifyEvent; - protected - procedure UpdateItemsThreshold(ASize: SizeInt); virtual; abstract; - - procedure KeyNotify(constref AKey: TKey; ACollectionNotification: TCollectionNotification); virtual; - procedure ValueNotify(constref AValue: TValue; ACollectionNotification: TCollectionNotification); virtual; - procedure PairNotify(constref APair: TDictionaryPair; ACollectionNotification: TCollectionNotification); inline; - procedure SetValue(var AValue: TValue; constref ANewValue: TValue); - public - property OnKeyNotify: TCollectionNotifyEvent read FOnKeyNotify write FOnKeyNotify; - property OnValueNotify: TCollectionNotifyEvent read FOnValueNotify write FOnValueNotify; - protected // FItemsLength must be declared at the end of TCustomDictionary - FItemsLength: SizeInt; - public - property Count: SizeInt read FItemsLength; - end; - - { TCustomDictionaryEnumerator } - - TCustomDictionaryEnumerator = class abstract(TEnumerator< T >) - private - FDictionary: TCustomDictionary; - FIndex: SizeInt; - protected - function DoGetCurrent: T; override; - function GetCurrent: T; virtual; abstract; - public - constructor Create(ADictionary: TCustomDictionary); - end; - - { TDictionaryEnumerable } - - TDictionaryEnumerable = class abstract(TEnumerableWithPointers) - private - FDictionary: TCustomDictionary; - function GetCount: SizeInt; - protected - function GetPtrEnumerator: TEnumerator; override; - function DoGetEnumerator: TDictionaryEnumerator; override; - public - constructor Create(ADictionary: TCustomDictionary); - function ToArray: TArray; override; final; - property Count: SizeInt read GetCount; - end; - - // more info : http://en.wikipedia.org/wiki/Open_addressing - - { TOpenAddressingEnumerator } - - TOpenAddressingEnumerator = class abstract(TCustomDictionaryEnumerator) - protected - function DoMoveNext: Boolean; override; - end; - - TOpenAddressingPointersEnumerator = class abstract(TEnumerator) - private var - FItems: ^TArray; - FIndex: SizeInt; - protected - function DoMoveNext: boolean; override; - function DoGetCurrent: PDictionaryPair; override; - function GetCurrent: PDictionaryPair; virtual; - public - constructor Create(var AItems); - end; - - TOpenAddressingPointersCollection = record - private type - PArray = ^TArray; - function Items: PArray; inline; - function GetCount: SizeInt; inline; - public - function GetEnumerator: TPointersEnumerator; - function ToArray: TArray; - property Count: SizeInt read GetCount; - end; - - TOnGetMemoryLayoutKeyPosition = procedure(Sender: TObject; AKeyPos: UInt32) of object; - - TOpenAddressing = class abstract(TCustomDictionary) - private type - PItem = ^TItem; - TItem = record - Hash: UInt32; - Pair: TPair; - end; - - TItemsArray = array of TItem; - TPointersEnumerator = class(TOpenAddressingPointersEnumerator); - TPointersCollection = TOpenAddressingPointersCollection; - public type - PPointersCollection = ^TPointersCollection; - private var // FItems must be declared as first field - FItems: TItemsArray; - FItemsThreshold: SizeInt; - - procedure Resize(ANewSize: SizeInt); - procedure PrepareAddingItem; - protected - function RealItemsLength: SizeInt; virtual; - function Rehash(ASizePow2: SizeInt; AForce: Boolean = False): boolean; virtual; - function FindBucketIndex(constref AKey: TKey): SizeInt; overload; inline; - function FindBucketIndex(constref AItems: TArray; constref AKey: TKey; out AHash: UInt32): SizeInt; virtual; abstract; overload; - public - type - // Enumerators - TPairEnumerator = class(TOpenAddressingEnumerator) - protected - function GetCurrent: TPair; override; - end; - - TValueEnumerator = class(TOpenAddressingEnumerator) - protected - function GetCurrent: TValue; override; - end; - - TPValueEnumerator = class(TOpenAddressingEnumerator) - protected - function GetCurrent: PValue; override; - end; - - TKeyEnumerator = class(TOpenAddressingEnumerator) - protected - function GetCurrent: TKey; override; - end; - - TPKeyEnumerator = class(TOpenAddressingEnumerator) - protected - function GetCurrent: PKey; override; - end; - - // Collections - TValueCollection = class(TDictionaryEnumerable); - - TKeyCollection = class(TDictionaryEnumerable); - - // bug #24283 - workaround related to lack of DoGetEnumerator - function GetEnumerator: TPairEnumerator; reintroduce; - private - function GetKeys: TKeyCollection; - function GetValues: TValueCollection; - function GetPointers: PPointersCollection; inline; - private - function GetItem(const AKey: TKey): TValue; inline; - procedure SetItem(const AKey: TKey; const AValue: TValue); inline; - procedure AddItem(var AItem: TItem; constref AKey: TKey; constref AValue: TValue; const AHash: UInt32); inline; - protected - // useful for using dictionary as array - function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): TValue; virtual; - function DoAdd(constref AKey: TKey; constref AValue: TValue): SizeInt; virtual; - - procedure UpdateItemsThreshold(ASize: SizeInt); override; - - procedure SetCapacity(ACapacity: SizeInt); override; - // bug #24283 - can't descadent from TEnumerable - function DoGetEnumerator: TEnumerator; override; - procedure SetMaxLoadFactor(AValue: single); override; - function GetLoadFactor: single; override; - function GetCapacity: SizeInt; override; - public - // many constructors because bug #25607 - constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer); override; overload; - - procedure Add(constref APair: TPair); override; overload; - procedure Add(constref AKey: TKey; constref AValue: TValue); overload; inline; - procedure Remove(constref AKey: TKey); - function ExtractPair(constref AKey: TKey): TPair; - procedure Clear; override; - procedure TrimExcess; - function TryGetValue(constref AKey: TKey; out AValue: TValue): Boolean; - procedure AddOrSetValue(constref AKey: TKey; constref AValue: TValue); - function ContainsKey(constref AKey: TKey): Boolean; inline; - function ContainsValue(constref AValue: TValue): Boolean; overload; - function ContainsValue(constref AValue: TValue; const AEqualityComparer: IEqualityComparer): Boolean; virtual; overload; - - property Items[Index: TKey]: TValue read GetItem write SetItem; default; - property Keys: TKeyCollection read GetKeys; - property Values: TValueCollection read GetValues; - property Ptr: PPointersCollection read GetPointers; - - procedure GetMemoryLayout(const AOnGetMemoryLayoutKeyPosition: TOnGetMemoryLayoutKeyPosition); - end; - - TOpenAddressingLP = class(TOpenAddressing) - private type // for workaround Lazarus bug #25613 - _TItem = record - Hash: UInt32; - Pair: TPair; - end; - protected - procedure NotifyIndexChange(AFrom, ATo: SizeInt); virtual; - function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): TValue; override; - function FindBucketIndex(constref AItems: TArray; constref AKey: TKey; out AHash: UInt32): SizeInt; override; overload; - end; - - // More info and TODO - // https://github.com/OpenHFT/UntitledCollectionsProject/wiki/Tombstones-purge-from-hashtable:-theory-and-practice - - TOpenAddressingTombstones = class abstract(TOpenAddressing) - private - FTombstonesCount: SizeInt; - protected - function Rehash(ASizePow2: SizeInt; AForce: Boolean = False): boolean; override; - function RealItemsLength: SizeInt; override; - - function FindBucketIndexOrTombstone(constref AItems: TArray; constref AKey: TKey; - out AHash: UInt32): SizeInt; virtual; abstract; - - function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): TValue; override; - function DoAdd(constref AKey: TKey; constref AValue: TValue): SizeInt; override; - public - property TombstonesCount: SizeInt read FTombstonesCount; - procedure ClearTombstones; virtual; - procedure Clear; override; - end; - - TOpenAddressingSH = class(TOpenAddressingTombstones) - private type // for workaround Lazarus bug #25613 - _TItem = record - Hash: UInt32; - Pair: TPair; - end; - protected - function FindBucketIndex(constref AItems: TArray; constref AKey: TKey; - out AHash: UInt32): SizeInt; override; overload; - function FindBucketIndexOrTombstone(constref AItems: TArray; constref AKey: TKey; - out AHash: UInt32): SizeInt; override; - end; - - TOpenAddressingQP = class(TOpenAddressingSH) - private - FPrimaryNumberAsSizeApproximation: SizeInt; - protected - procedure UpdateItemsThreshold(ASize: SizeInt); override; - function FindBucketIndex(constref AItems: TArray; - constref AKey: TKey; out AHash: UInt32): SizeInt; override; overload; - function FindBucketIndexOrTombstone(constref AItems: TArray; - constref AKey: TKey; out AHash: UInt32): SizeInt; override; - end; - - TOpenAddressingDH = class(TOpenAddressingTombstones) - private type // for workaround Lazarus bug #25613 - _TItem = record - Hash: UInt32; - Pair: TPair; - end; - private - R: UInt32; - protected - procedure UpdateItemsThreshold(ASize: SizeInt); override; - function FindBucketIndex(constref AItems: TArray; constref AKey: TKey; - out AHash: UInt32): SizeInt; override; overload; - function FindBucketIndexOrTombstone(constref AItems: TArray; constref AKey: TKey; - out AHash: UInt32): SizeInt; override; - strict protected - constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer); override; overload; - constructor Create(const AComparer: IEqualityComparer); reintroduce; overload; - constructor Create(ACollection: TEnumerable; const AComparer: IEqualityComparer); override; overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - constructor Create(ACollection: TEnumerableWithPointers; const AComparer: IEqualityComparer); override; overload; - {$ENDIF} - public // bug #26181 (redundancy of constructors) - constructor Create(ACapacity: SizeInt); override; overload; - constructor Create(ACollection: TEnumerable); override; overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - constructor Create(ACollection: TEnumerableWithPointers); override; overload; - {$ENDIF} - constructor Create(ACapacity: SizeInt; const AComparer: IExtendedEqualityComparer); virtual; overload; - constructor Create(const AComparer: IExtendedEqualityComparer); overload; - constructor Create(ACollection: TEnumerable; const AComparer: IExtendedEqualityComparer); virtual; overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - constructor Create(ACollection: TEnumerableWithPointers; const AComparer: IExtendedEqualityComparer); virtual; overload; - {$ENDIF} - end; - - TDeamortizedDArrayCuckooMapEnumerator = class abstract(TCustomDictionaryEnumerator) - private type // for workaround Lazarus bug #25613 - TItem = record - Hash: UInt32; - Pair: TPair; - end; - TItemsArray = array of TItem; - private - FMainIndex: SizeInt; - protected - function DoMoveNext: Boolean; override; - public - constructor Create(ADictionary: TCustomDictionary); - end; - - TDeamortizedDArrayPointersEnumerator = class abstract(TEnumerator) - private var // FItems must be declared as first field and FQueue as second - FItems: ^TItemsDArray; - FQueue: TQueueDictionary; - FIndex: SizeInt; - FMainIndex: SizeInt; - protected - function DoMoveNext: boolean; override; - function DoGetCurrent: PDictionaryPair; override; - function GetCurrent: PDictionaryPair; virtual; - public - constructor Create(var AItems; AQueue: TQueueDictionary; ACount: SizeInt); - end; - - TDeamortizedDArrayPointersCollection = record - private type - PArray = ^TItemsDArray; - function Items: PArray; inline; - function GetCount: SizeInt; inline; - function GetQueue: TQueueDictionary; inline; - public - function GetEnumerator: TPointersEnumerator; - function ToArray: TArray; - property Count: SizeInt read GetCount; - end; - - // more info : - // http://arxiv.org/abs/0903.0391 - - TDeamortizedDArrayCuckooMap = class(TCustomDictionary) - private const // Lookup Result - LR_NIL = -1; - LR_QUEUE = -2; - private type - PItem = ^TItem; - TItem = record - Hash: UInt32; - Pair: TPair; - end; - TValueForQueue = TItem; - - TQueueDictionary = class(TOpenAddressingLP) - private type // for workaround Lazarus bug #25613 - _TItem = record - Hash: UInt32; - Pair: TPair; - end; - private - FIdx: TList; // list to keep order - protected - procedure NotifyIndexChange(AFrom, ATo: SizeInt); override; - function Rehash(ASizePow2: SizeInt; AForce: Boolean = False): Boolean; override; - public - procedure InsertIntoBack(AItem: Pointer); - procedure InsertIntoHead(AItem: Pointer); - function IsEmpty: Boolean; - function Pop: Pointer; - constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer); override; overload; - destructor Destroy; override; - end; - - // cycle-detection mechanism class - TCDM = class(TOpenAddressingSH); - TItemsArray = array of TItem; - TItemsDArray = array[0..Pred(TCuckooCfg.D)] of TItemsArray; - TPointersEnumerator = class(TDeamortizedDArrayPointersEnumerator); - TPointersCollection = TDeamortizedDArrayPointersCollection; - public type - PPointersCollection = ^TPointersCollection; - private var - FItems: TItemsDArray; - FQueue: TQueueDictionary; // probably can be optimized - hash TItem give information from TItem.Hash for cuckoo ... - // currently is kept in "TQueueDictionary = class(TOpenAddressingSH" - - FCDM: TCDM; // cycle-detection mechanism - FItemsThreshold: SizeInt; - // sadly there is bug #24848 for class var ... - {class} var - CUCKOO_SIGN, CUCKOO_INDEX_SIZE, CUCKOO_HASH_SIGN: UInt32; - // CUCKOO_MAX_ITEMS_LENGTH: <- to do : calc max length for items based on CUCKOO sign - // maybe some CDM bloom filter? - - procedure Resize(ANewSize: SizeInt); - procedure Rehash(ASizePow2: SizeInt); - procedure PrepareAddingItem; - protected - procedure UpdateItemsThreshold(ASize: SizeInt); override; - function Lookup(constref AKey: TKey; var AHashListOrIndex: PUInt32): SizeInt; inline; overload; - function Lookup(constref AItems: TItemsDArray; constref AKey: TKey; var AHashListOrIndex: PUInt32): SizeInt; virtual; overload; - public - type - // Enumerators - TPairEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator) - protected - function GetCurrent: TPair; override; - end; - - TValueEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator) - protected - function GetCurrent: TValue; override; - end; - - TPValueEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator) - protected - function GetCurrent: PValue; override; - end; - - TKeyEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator) - protected - function GetCurrent: TKey; override; - end; - - TPKeyEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator) - protected - function GetCurrent: PKey; override; - end; - - // Collections - TValueCollection = class(TDictionaryEnumerable); - - TKeyCollection = class(TDictionaryEnumerable); - - // bug #24283 - workaround related to lack of DoGetEnumerator - function GetEnumerator: TPairEnumerator; reintroduce; - private - function GetKeys: TKeyCollection; - function GetValues: TValueCollection; - function GetPointers: PPointersCollection; inline; - private - function GetItem(const AKey: TKey): TValue; inline; - procedure SetItem(const AKey: TKey; const AValue: TValue); overload; inline; - procedure SetItem(constref AValue: TValue; const AHashListOrIndex: PUInt32; ALookupResult: SizeInt); overload; - - procedure AddItem(constref AItems: TItemsDArray; constref AKey: TKey; constref AValue: TValue; const AHashList: PUInt32); overload; - procedure DoAdd(const AKey: TKey; const AValue: TValue; const AHashList: PUInt32); overload; inline; - function DoRemove(const AHashListOrIndex: PUInt32; ALookupResult: SizeInt; - ACollectionNotification: TCollectionNotification): TValue; - - function GetQueueCount: SizeInt; - protected - procedure SetCapacity(ACapacity: SizeInt); override; - // bug #24283 - can't descadent from TEnumerable - function DoGetEnumerator: TEnumerator; override; - procedure SetMaxLoadFactor(AValue: single); override; - function GetLoadFactor: single; override; - function GetCapacity: SizeInt; override; - strict protected // bug #26181 - constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer); override; overload; - constructor Create(const AComparer: IEqualityComparer); reintroduce; overload; - constructor Create(ACollection: TEnumerable; const AComparer: IEqualityComparer); override; overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - constructor Create(ACollection: TEnumerableWithPointers; const AComparer: IEqualityComparer); override; overload; - {$ENDIF} - public - // TODO: function TryFlushQueue(ACount: SizeInt): SizeInt; - - constructor Create; override; overload; - constructor Create(ACapacity: SizeInt); override; overload; - constructor Create(ACollection: TEnumerable); override; overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - constructor Create(ACollection: TEnumerableWithPointers); override; overload; - {$ENDIF} - constructor Create(ACapacity: SizeInt; const AComparer: IExtendedEqualityComparer); virtual; overload; - constructor Create(const AComparer: IExtendedEqualityComparer); overload; - constructor Create(ACollection: TEnumerable; const AComparer: IExtendedEqualityComparer); virtual; overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - constructor Create(ACollection: TEnumerableWithPointers; const AComparer: IExtendedEqualityComparer); virtual; overload; - {$ENDIF} - destructor Destroy; override; - - procedure Add(constref APair: TPair); override; overload; - procedure Add(constref AKey: TKey; constref AValue: TValue); overload; - procedure Remove(constref AKey: TKey); - function ExtractPair(constref AKey: TKey): TPair; - procedure Clear; override; - procedure TrimExcess; - function TryGetValue(constref AKey: TKey; out AValue: TValue): Boolean; - procedure AddOrSetValue(constref AKey: TKey; constref AValue: TValue); - function ContainsKey(constref AKey: TKey): Boolean; inline; - function ContainsValue(constref AValue: TValue): Boolean; overload; - function ContainsValue(constref AValue: TValue; const AEqualityComparer: IEqualityComparer): Boolean; virtual; overload; - - property Items[Index: TKey]: TValue read GetItem write SetItem; default; - property Keys: TKeyCollection read GetKeys; - property Values: TValueCollection read GetValues; - property Ptr: PPointersCollection read GetPointers; - - property QueueCount: SizeInt read GetQueueCount; - procedure GetMemoryLayout(const AOnGetMemoryLayoutKeyPosition: TOnGetMemoryLayoutKeyPosition); - end; - - TDictionaryOwnerships = set of (doOwnsKeys, doOwnsValues); - - TObjectDeamortizedDArrayCuckooMap = class(TDeamortizedDArrayCuckooMap) - private - FOwnerships: TDictionaryOwnerships; - protected - procedure KeyNotify(constref AKey: TKey; ACollectionNotification: TCollectionNotification); override; - procedure ValueNotify(constref AValue: TValue; ACollectionNotification: TCollectionNotification); override; - public - // can't be as "Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt = 0)" - // because bug #25607 - constructor Create(AOwnerships: TDictionaryOwnerships); overload; - constructor Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt); overload; - constructor Create(AOwnerships: TDictionaryOwnerships; - const AComparer: IExtendedEqualityComparer); overload; - constructor Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt; - const AComparer: IExtendedEqualityComparer); overload; - end; - - TObjectOpenAddressingLP = class(TOpenAddressingLP) - private - FOwnerships: TDictionaryOwnerships; - protected - procedure KeyNotify(constref AKey: TKey; ACollectionNotification: TCollectionNotification); override; - procedure ValueNotify(constref AValue: TValue; ACollectionNotification: TCollectionNotification); override; - public - // can't be as "Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt = 0)" - // because bug #25607 - constructor Create(AOwnerships: TDictionaryOwnerships); overload; - constructor Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt); overload; - constructor Create(AOwnerships: TDictionaryOwnerships; - const AComparer: IEqualityComparer); overload; - constructor Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt; - const AComparer: IEqualityComparer); overload; - end; - - // useful generics overloads - TOpenAddressingLP = class(TOpenAddressingLP); - TOpenAddressingLP = class(TOpenAddressingLP); - - TObjectOpenAddressingLP = class(TObjectOpenAddressingLP); - TObjectOpenAddressingLP = class(TObjectOpenAddressingLP); - - // Linear Probing with Tombstones (LPT) - TOpenAddressingLPT = class(TOpenAddressingSH); - TOpenAddressingLPT = class(TOpenAddressingSH); - - TOpenAddressingQP = class(TOpenAddressingQP); - TOpenAddressingQP = class(TOpenAddressingQP); - - TOpenAddressingDH = class(TOpenAddressingDH); - TOpenAddressingDH = class(TOpenAddressingDH); - - TCuckooD2 = class(TDeamortizedDArrayCuckooMap); - TCuckooD2 = class(TDeamortizedDArrayCuckooMap); - - TCuckooD4 = class(TDeamortizedDArrayCuckooMap); - TCuckooD4 = class(TDeamortizedDArrayCuckooMap); - - TCuckooD6 = class(TDeamortizedDArrayCuckooMap); - TCuckooD6 = class(TDeamortizedDArrayCuckooMap); - - TObjectCuckooD2 = class(TObjectDeamortizedDArrayCuckooMap); - TObjectCuckooD2 = class(TObjectDeamortizedDArrayCuckooMap); - - TObjectCuckooD4 = class(TObjectDeamortizedDArrayCuckooMap); - TObjectCuckooD4 = class(TObjectDeamortizedDArrayCuckooMap); - - TObjectCuckooD6 = class(TObjectDeamortizedDArrayCuckooMap); - TObjectCuckooD6 = class(TObjectDeamortizedDArrayCuckooMap); - - // for normal programmers to normal use =) - TDictionary = class(TOpenAddressingLP); - TObjectDictionary = class(TObjectOpenAddressingLP); - - TFastHashMap = class(TCuckooD2); - TFastObjectHashMap = class(TObjectCuckooD2); - - THashMap = class(TCuckooD4); - TObjectHashMap = class(TObjectCuckooD4); diff --git a/components/sparta/generics/source/sparta_generics.collections.pas b/components/sparta/generics/source/sparta_generics.collections.pas deleted file mode 100644 index c2e1496d8a..0000000000 --- a/components/sparta/generics/source/sparta_generics.collections.pas +++ /dev/null @@ -1,4207 +0,0 @@ -{ - This file is part of the Free Pascal/NewPascal run time library. - Copyright (c) 2014 by Maciej Izak (hnb) - member of the NewPascal development team (http://newpascal.org) - - Copyright(c) 2004-2018 DaThoX - - It contains the generics collections 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. - - Acknowledgment - - Thanks to Sphere 10 Software (http://sphere10.com) for sponsoring - many new types and major refactoring of entire library - - Thanks to mORMot (http://synopse.info) project for the best implementations - of hashing functions like crc32c and xxHash32 :) - - **********************************************************************} - -unit sparta_Generics.Collections; - -{$WARNING Package Sparta_Generics is deprecated} -{$WARNING You can use FPC 3.2.0+ Generics instead} -{$MODE DELPHI}{$H+} -{$MACRO ON} -{$COPERATORS ON} -{$DEFINE CUSTOM_DICTIONARY_CONSTRAINTS := TKey, TValue, THashFactory} -{$DEFINE OPEN_ADDRESSING_CONSTRAINTS := TKey, TValue, THashFactory, TProbeSequence} -{$DEFINE CUCKOO_CONSTRAINTS := TKey, TValue, THashFactory, TCuckooCfg} -{$DEFINE TREE_CONSTRAINTS := TKey, TValue, TInfo} -{$WARNINGS OFF} -{$HINTS OFF} -{$OVERFLOWCHECKS OFF} -{$RANGECHECKS OFF} - -interface - -uses - RtlConsts, Classes, SysUtils, - sparta_Generics.MemoryExpanders, sparta_Generics.Defaults, - sparta_Generics.Helpers, sparta_Generics.Strings; - -{.$define EXTRA_WARNINGS} -{.$define ENABLE_METHODS_WITH_TEnumerableWithPointers} - -type - EAVLTree = class(Exception); - EIndexedAVLTree = class(EAVLTree); - - TDuplicates = Classes.TDuplicates; - - {$ifdef VER3_0_0} - TArray = array of T; - {$endif} - - // bug #24254 workaround - // should be TArray = record class procedure Sort(...) etc. - TBinarySearchResult = record - FoundIndex, CandidateIndex: SizeInt; - CompareResult: SizeInt; - end; - - TCustomArrayHelper = class abstract - private - type - // bug #24282 - TComparerBugHack = TComparer; - protected - // modified QuickSort from classes\lists.inc - class procedure QuickSort(var AValues: array of T; ALeft, ARight: SizeInt; const AComparer: IComparer); - virtual; abstract; - public - class procedure Sort(var AValues: array of T); overload; - class procedure Sort(var AValues: array of T; - const AComparer: IComparer); overload; - class procedure Sort(var AValues: array of T; - const AComparer: IComparer; AIndex, ACount: SizeInt); overload; - - class function BinarySearch(constref AValues: array of T; constref AItem: T; - out ASearchResult: TBinarySearchResult; const AComparer: IComparer; - AIndex, ACount: SizeInt): Boolean; virtual; abstract; overload; - class function BinarySearch(constref AValues: array of T; constref AItem: T; - out AFoundIndex: SizeInt; const AComparer: IComparer; - AIndex, ACount: SizeInt): Boolean; virtual; abstract; overload; - class function BinarySearch(constref AValues: array of T; constref AItem: T; - out AFoundIndex: SizeInt; const AComparer: IComparer): Boolean; overload; - class function BinarySearch(constref AValues: array of T; constref AItem: T; - out AFoundIndex: SizeInt): Boolean; overload; - class function BinarySearch(constref AValues: array of T; constref AItem: T; - out ASearchResult: TBinarySearchResult; const AComparer: IComparer): Boolean; overload; - class function BinarySearch(constref AValues: array of T; constref AItem: T; - out ASearchResult: TBinarySearchResult): Boolean; overload; - end {$ifdef EXTRA_WARNINGS}experimental{$endif}; // will be renamed to TCustomArray (bug #24254) - - TArrayHelper = class(TCustomArrayHelper) - protected - // modified QuickSort from classes\lists.inc - class procedure QuickSort(var AValues: array of T; ALeft, ARight: SizeInt; const AComparer: IComparer); override; - public - class function BinarySearch(constref AValues: array of T; constref AItem: T; - out ASearchResult: TBinarySearchResult; const AComparer: IComparer; - AIndex, ACount: SizeInt): Boolean; override; overload; - class function BinarySearch(constref AValues: array of T; constref AItem: T; - out AFoundIndex: SizeInt; const AComparer: IComparer; - AIndex, ACount: SizeInt): Boolean; override; overload; - end {$ifdef EXTRA_WARNINGS}experimental{$endif}; // will be renamed to TArray (bug #24254) - - TCollectionNotification = (cnAdded, cnRemoved, cnExtracted); - TCollectionNotifyEvent = procedure(ASender: TObject; constref AItem: T; AAction: TCollectionNotification) - of object; - - { TEnumerator } - - TEnumerator = class abstract - protected - function DoGetCurrent: T; virtual; abstract; - function DoMoveNext: boolean; virtual; abstract; - public - property Current: T read DoGetCurrent; - function MoveNext: boolean; - end; - - { TEnumerable } - - TEnumerable = class abstract - public type - PT = ^T; - protected // no forward generics declarations (needed by TPointersCollection), this should be moved into TEnumerableWithPointers - function GetPtrEnumerator: TEnumerator; virtual; abstract; - protected - function ToArrayImpl(ACount: SizeInt): TArray; overload; // used by descendants - protected - function DoGetEnumerator: TEnumerator; virtual; abstract; - public - function GetEnumerator: TEnumerator; inline; - function ToArray: TArray; virtual; overload; - end; - - // error: no memory left for TCustomPointersEnumerator version - TCustomPointersEnumerator = class abstract(TEnumerator); - - TCustomPointersCollection = object - strict private type - TLocalEnumerable = TEnumerable; // compiler has bug for directly usage of TEnumerable - protected - function Enumerable: TLocalEnumerable; inline; - public - function GetEnumerator: TEnumerator; - end; - - TEnumerableWithPointers = class(TEnumerable) - strict private type - TPointersCollection = TCustomPointersCollection; - PPointersCollection = ^TPointersCollection; - private - function GetPtr: PPointersCollection; inline; - public - property Ptr: PPointersCollection read GetPtr; - end; - - // More info: http://stackoverflow.com/questions/5232198/about-vectors-growth - // TODO: custom memory managers (as constraints) - {$DEFINE CUSTOM_LIST_CAPACITY_INC := Result + Result div 2} // ~approximation to golden ratio: n = n * 1.5 } - // {$DEFINE CUSTOM_LIST_CAPACITY_INC := Result * 2} // standard inc - TCustomList = class abstract(TEnumerableWithPointers) - public type - PT = ^T; - protected - type // bug #24282 - TArrayHelperBugHack = TArrayHelper; - private - FOnNotify: TCollectionNotifyEvent; - function GetCapacity: SizeInt; inline; - protected - FLength: SizeInt; - FItems: array of T; - - function PrepareAddingItem: SizeInt; virtual; - function PrepareAddingRange(ACount: SizeInt): SizeInt; virtual; - procedure Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); virtual; - function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): T; virtual; - procedure SetCapacity(AValue: SizeInt); virtual; abstract; - function GetCount: SizeInt; virtual; - public - function ToArray: TArray; override; final; - - property Count: SizeInt read GetCount; - property Capacity: SizeInt read GetCapacity write SetCapacity; - property OnNotify: TCollectionNotifyEvent read FOnNotify write FOnNotify; - - procedure TrimExcess; virtual; abstract; - end; - - TCustomListEnumerator = class abstract(TEnumerator) - private - FList: TCustomList; - FIndex: SizeInt; - protected - function DoMoveNext: boolean; override; - function DoGetCurrent: T; override; - function GetCurrent: T; virtual; - public - constructor Create(AList: TCustomList); - end; - - TCustomListWithPointers = class(TCustomList) - public type - TPointersEnumerator = class(TCustomPointersEnumerator) - protected - FList: TCustomListWithPointers; - FIndex: SizeInt; - function DoMoveNext: boolean; override; - function DoGetCurrent: PT; override; - public - constructor Create(AList: TCustomListWithPointers); - end; - protected - function GetPtrEnumerator: TEnumerator; override; - end; - - TList = class(TCustomListWithPointers) - private var - FComparer: IComparer; - protected - // bug #24287 - workaround for generics type name conflict (Identifier not found) - // next bug workaround - for another error related to previous workaround - // change order (method must be declared before TEnumerator declaration) - function DoGetEnumerator: {Generics.Collections.}TEnumerator; override; - public - // with this type declaration i found #24285, #24285 - type - // bug workaround - TEnumerator = class(TCustomListEnumerator); - - function GetEnumerator: TEnumerator; reintroduce; - protected - procedure SetCapacity(AValue: SizeInt); override; - procedure SetCount(AValue: SizeInt); - procedure InitializeList; virtual; - procedure InternalInsert(AIndex: SizeInt; constref AValue: T); - private - function GetItem(AIndex: SizeInt): T; - procedure SetItem(AIndex: SizeInt; const AValue: T); - public - constructor Create; overload; - constructor Create(const AComparer: IComparer); overload; - constructor Create(ACollection: TEnumerable); overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - constructor Create(ACollection: TEnumerableWithPointers); overload; - {$ENDIF} - destructor Destroy; override; - - function Add(constref AValue: T): SizeInt; virtual; - procedure AddRange(constref AValues: array of T); virtual; overload; - procedure AddRange(const AEnumerable: IEnumerable); overload; - procedure AddRange(AEnumerable: TEnumerable); overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - procedure AddRange(AEnumerable: TEnumerableWithPointers); overload; - {$ENDIF} - - procedure Insert(AIndex: SizeInt; constref AValue: T); virtual; - procedure InsertRange(AIndex: SizeInt; constref AValues: array of T); virtual; overload; - procedure InsertRange(AIndex: SizeInt; const AEnumerable: IEnumerable); overload; - procedure InsertRange(AIndex: SizeInt; const AEnumerable: TEnumerable); overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - procedure InsertRange(AIndex: SizeInt; const AEnumerable: TEnumerableWithPointers); overload; - {$ENDIF} - - function Remove(constref AValue: T): SizeInt; - procedure Delete(AIndex: SizeInt); inline; - procedure DeleteRange(AIndex, ACount: SizeInt); - function ExtractIndex(const AIndex: SizeInt): T; overload; - function Extract(constref AValue: T): T; overload; - - procedure Exchange(AIndex1, AIndex2: SizeInt); virtual; - procedure Move(AIndex, ANewIndex: SizeInt); virtual; - - function First: T; inline; - function Last: T; inline; - - procedure Clear; - - function Contains(constref AValue: T): Boolean; inline; - function IndexOf(constref AValue: T): SizeInt; virtual; - function LastIndexOf(constref AValue: T): SizeInt; virtual; - - procedure Reverse; - - procedure TrimExcess; override; - - procedure Sort; overload; - procedure Sort(const AComparer: IComparer); overload; - function BinarySearch(constref AItem: T; out AIndex: SizeInt): Boolean; overload; - function BinarySearch(constref AItem: T; out AIndex: SizeInt; const AComparer: IComparer): Boolean; overload; - - property Count: SizeInt read FLength write SetCount; - property Items[Index: SizeInt]: T read GetItem write SetItem; default; - end; - - TCollectionSortStyle = (cssNone,cssUser,cssAuto); - TCollectionSortStyles = Set of TCollectionSortStyle; - - TSortedList = class(TList) - private - FDuplicates: TDuplicates; - FSortStyle: TCollectionSortStyle; - function GetSorted: boolean; - procedure SetSorted(AValue: boolean); - procedure SetSortStyle(AValue: TCollectionSortStyle); - protected - procedure InitializeList; override; - public - function Add(constref AValue: T): SizeInt; override; overload; - procedure AddRange(constref AValues: array of T); override; overload; - procedure Insert(AIndex: SizeInt; constref AValue: T); override; - procedure Exchange(AIndex1, AIndex2: SizeInt); override; - procedure Move(AIndex, ANewIndex: SizeInt); override; - procedure InsertRange(AIndex: SizeInt; constref AValues: array of T); override; overload; - property Duplicates: TDuplicates read FDuplicates write FDuplicates; - property Sorted: Boolean read GetSorted write SetSorted; - property SortStyle: TCollectionSortStyle read FSortStyle write SetSortStyle; - - function ConsistencyCheck(ARaiseException: boolean = true): boolean; virtual; - end; - - TThreadList = class - private - FList: TList; - FDuplicates: TDuplicates; - FLock: TRTLCriticalSection; - public - constructor Create; - destructor Destroy; override; - - procedure Add(constref AValue: T); - procedure Remove(constref AValue: T); - procedure Clear; - - function LockList: TList; - procedure UnlockList; inline; - - property Duplicates: TDuplicates read FDuplicates write FDuplicates; - end; - - TQueue = class(TCustomList) - public type - TPointersEnumerator = class(TCustomPointersEnumerator) - protected - FQueue: TQueue; - FIndex: SizeInt; - function DoMoveNext: boolean; override; - function DoGetCurrent: PT; override; - public - constructor Create(AQueue: TQueue); - end; - protected - function GetPtrEnumerator: TEnumerator; override; - protected - // bug #24287 - workaround for generics type name conflict (Identifier not found) - // next bug workaround - for another error related to previous workaround - // change order (function must be declared before TEnumerator declaration} - function DoGetEnumerator: {Generics.Collections.}TEnumerator; override; - public - type - TEnumerator = class(TCustomListEnumerator) - public - constructor Create(AQueue: TQueue); - end; - - function GetEnumerator: TEnumerator; reintroduce; - private - FLow: SizeInt; - protected - procedure SetCapacity(AValue: SizeInt); override; - function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): T; override; - function GetCount: SizeInt; override; - public - constructor Create(ACollection: TEnumerable); overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - constructor Create(ACollection: TEnumerableWithPointers); overload; - {$ENDIF} - destructor Destroy; override; - procedure Enqueue(constref AValue: T); - function Dequeue: T; - function Extract: T; - function Peek: T; - procedure Clear; - procedure TrimExcess; override; - end; - - TStack = class(TCustomListWithPointers) - protected - // bug #24287 - workaround for generics type name conflict (Identifier not found) - // next bug workaround - for another error related to previous workaround - // change order (function must be declared before TEnumerator declaration} - function DoGetEnumerator: {Generics.Collections.}TEnumerator; override; - public - type - TEnumerator = class(TCustomListEnumerator); - - function GetEnumerator: TEnumerator; reintroduce; - protected - function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): T; override; - procedure SetCapacity(AValue: SizeInt); override; - public - constructor Create(ACollection: TEnumerable); overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - constructor Create(ACollection: TEnumerableWithPointers); overload; - {$ENDIF} - destructor Destroy; override; - procedure Clear; - procedure Push(constref AValue: T); - function Pop: T; inline; - function Peek: T; - function Extract: T; inline; - procedure TrimExcess; override; - end; - - TObjectList = class(TList) - private - FObjectsOwner: Boolean; - protected - procedure Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); override; - public - constructor Create(AOwnsObjects: Boolean = True); overload; - constructor Create(const AComparer: IComparer; AOwnsObjects: Boolean = True); overload; - constructor Create(ACollection: TEnumerable; AOwnsObjects: Boolean = True); overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - constructor Create(ACollection: TEnumerableWithPointers; AOwnsObjects: Boolean = True); overload; - {$ENDIF} - property OwnsObjects: Boolean read FObjectsOwner write FObjectsOwner; - end; - - TObjectQueue = class(TQueue) - private - FObjectsOwner: Boolean; - protected - procedure Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); override; - public - constructor Create(AOwnsObjects: Boolean = True); overload; - constructor Create(ACollection: TEnumerable; AOwnsObjects: Boolean = True); overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - constructor Create(ACollection: TEnumerableWithPointers; AOwnsObjects: Boolean = True); overload; - {$ENDIF} - procedure Dequeue; - property OwnsObjects: Boolean read FObjectsOwner write FObjectsOwner; - end; - - TObjectStack = class(TStack) - private - FObjectsOwner: Boolean; - protected - procedure Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); override; - public - constructor Create(AOwnsObjects: Boolean = True); overload; - constructor Create(ACollection: TEnumerable; AOwnsObjects: Boolean = True); overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - constructor Create(ACollection: TEnumerableWithPointers; AOwnsObjects: Boolean = True); overload; - {$ENDIF} - function Pop: T; - property OwnsObjects: Boolean read FObjectsOwner write FObjectsOwner; - end; - - PObject = ^TObject; - -{$I inc\generics.dictionariesh.inc} - - { TCustomHashSet } - - TCustomSet = class(TEnumerableWithPointers) - protected - FOnNotify: TCollectionNotifyEvent; - public type - PT = ^T; - protected type - TCustomSetEnumerator = class(TEnumerator) - protected var - FEnumerator: TEnumerator; - function DoMoveNext: boolean; override; - function DoGetCurrent: T; override; - function GetCurrent: T; virtual; abstract; - public - constructor Create(ASet: TCustomSet); virtual; abstract; - destructor Destroy; override; - end; - protected - function DoGetEnumerator: TEnumerator; override; - function GetCount: SizeInt; virtual; abstract; - function GetCapacity: SizeInt; virtual; abstract; - procedure SetCapacity(AValue: SizeInt); virtual; abstract; - function GetOnNotify: TCollectionNotifyEvent; virtual; abstract; - procedure SetOnNotify(AValue: TCollectionNotifyEvent); virtual; abstract; - public - constructor Create; virtual; abstract; overload; - constructor Create(ACollection: TEnumerable); overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - constructor Create(ACollection: TEnumerableWithPointers); overload; - {$ENDIF} - function GetEnumerator: TCustomSetEnumerator; reintroduce; virtual; abstract; - - function Add(constref AValue: T): Boolean; virtual; abstract; - function Remove(constref AValue: T): Boolean; virtual; abstract; - function Extract(constref AValue: T): T; virtual; abstract; - - procedure Clear; virtual; abstract; - function Contains(constref AValue: T): Boolean; virtual; abstract; - function AddRange(constref AValues: array of T): Boolean; overload; - function AddRange(const AEnumerable: IEnumerable): Boolean; overload; - function AddRange(AEnumerable: TEnumerable): Boolean; overload; - {$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} - function AddRange(AEnumerable: TEnumerableWithPointers): Boolean; overload; - {$ENDIF} - procedure UnionWith(AHashSet: TCustomSet); - procedure IntersectWith(AHashSet: TCustomSet); - procedure ExceptWith(AHashSet: TCustomSet); - procedure SymmetricExceptWith(AHashSet: TCustomSet); - - property Count: SizeInt read GetCount; - property Capacity: SizeInt read GetCapacity write SetCapacity; - procedure TrimExcess; virtual; abstract; - - property OnNotify: TCollectionNotifyEvent read GetOnNotify write SetOnNotify; - end; - - { THashSet } - - THashSet = class(TCustomSet) - private - procedure InternalDictionaryNotify(ASender: TObject; constref AItem: T; AAction: TCollectionNotification); - protected - FInternalDictionary: TOpenAddressingLP; - public type - THashSetEnumerator = class(TCustomSetEnumerator) - protected type - TDictionaryEnumerator = TDictionary.TKeyEnumerator; - function GetCurrent: T; override; - public - constructor Create(ASet: TCustomSet); override; - end; - - TPointersEnumerator = class(TCustomPointersEnumerator) - protected - FEnumerator: TEnumerator; - function DoMoveNext: boolean; override; - function DoGetCurrent: PT; override; - public - constructor Create(AHashSet: THashSet); - end; - protected - function GetPtrEnumerator: TEnumerator; override; - function GetCount: SizeInt; override; - function GetCapacity: SizeInt; override; - procedure SetCapacity(AValue: SizeInt); override; - function GetOnNotify: TCollectionNotifyEvent; override; - procedure SetOnNotify(AValue: TCollectionNotifyEvent); override; - public - constructor Create; override; overload; - constructor Create(const AComparer: IEqualityComparer); virtual; overload; - destructor Destroy; override; - function GetEnumerator: TCustomSetEnumerator; override; - - function Add(constref AValue: T): Boolean; override; - function Remove(constref AValue: T): Boolean; override; - function Extract(constref AValue: T): T; override; - - procedure Clear; override; - function Contains(constref AValue: T): Boolean; override; - - procedure TrimExcess; override; - end; - - TPair = record - public - Key: TKey; - Value: TValue; - Info: TInfo; - end; - - TAVLTreeNode = record - private type - TNodePair = TPair; - public type - PNode = ^TAVLTreeNode; - public - Parent, Left, Right: PNode; - Balance: Integer; - Data: TNodePair; - function Successor: PNode; - function Precessor: PNode; - function TreeDepth: integer; - procedure ConsistencyCheck(ATree: TObject); // workaround for internal error 2012101001 (no generic forward declarations) - function GetCount: SizeInt; - property Key: TKey read Data.Key write Data.Key; - property Value: TValue read Data.Value write Data.Value; - property Info: TInfo read Data.Info write Data.Info; - end; - - TCustomTreeEnumerator = class abstract(TEnumerator) - protected - FCurrent: PNode; - FTree: TTree; - function DoGetCurrent: T; override; - function GetCurrent: T; virtual; abstract; - public - constructor Create(ATree: TObject); - property Current: T read GetCurrent; - end; - - TTreeEnumerable = class abstract(TEnumerableWithPointers) - private - FTree: TTree; - function GetCount: SizeInt; inline; - protected - function GetPtrEnumerator: TEnumerator; override; - function DoGetEnumerator: TTreeEnumerator; override; - public - constructor Create(ATree: TTree); - function ToArray: TArray; override; final; - property Count: SizeInt read GetCount; - end; - - TAVLTreeEnumerator = class(TCustomTreeEnumerator) - protected - FLowToHigh: boolean; - function DoMoveNext: Boolean; override; - public - constructor Create(ATree: TObject; ALowToHigh: boolean = true); - property LowToHigh: boolean read FLowToHigh; - end; - - TNodeNotifyEvent = procedure(ASender: TObject; ANode: PNode; AAction: TCollectionNotification; ADispose: boolean) of object; - - TCustomAVLTreeMap = class - private type - TTree = class(TCustomAVLTreeMap); - public type - TNode = TAVLTreeNode; - PNode = ^TNode; - PPNode = ^PNode; - TTreePair = TPair; - PKey = ^TKey; - PValue = ^TValue; - private type - // type exist only for generic constraint in TNodeCollection (non functional - PPNode has no sense) - TPNodeEnumerator = class(TAVLTreeEnumerator); - private var - FDuplicates: TDuplicates; - FComparer: IComparer; - protected - FCount: SizeInt; - FRoot: PNode; - FKeys: TEnumerable; - FValues: TEnumerable; - FOnNodeNotify: TNodeNotifyEvent; - FOnKeyNotify: TCollectionNotifyEvent; - FOnValueNotify: TCollectionNotifyEvent; - - procedure NodeAdded(ANode: PNode); virtual; - procedure DeletingNode(ANode: PNode; AOrigin: boolean); virtual; - - function DoRemove(ANode: PNode; ACollectionNotification: TCollectionNotification; ADispose: boolean): TValue; - procedure DisposeAllNodes(ANode: PNode); overload; - - function Compare(constref ALeft, ARight: TKey): Integer; inline; - function FindPredecessor(ANode: PNode): PNode; - function FindInsertNode(ANode: PNode; out AInsertNode: PNode): Integer; - - procedure RotateRightRight(ANode: PNode); virtual; - procedure RotateLeftLeft(ANode: PNode); virtual; - procedure RotateRightLeft(ANode: PNode); virtual; - procedure RotateLeftRight(ANode: PNode); virtual; - - procedure KeyNotify(constref AKey: TKey; ACollectionNotification: TCollectionNotification); inline; - procedure ValueNotify(constref AValue: TValue; ACollectionNotification: TCollectionNotification); inline; - procedure NodeNotify(ANode: PNode; ACollectionNotification: TCollectionNotification; ADispose: boolean); inline; - procedure SetValue(var AValue: TValue; constref ANewValue: TValue); - function GetItem(const AKey: TKey): TValue; - procedure SetItem(const AKey: TKey; const AValue: TValue); - - property Items[Index: TKey]: TValue read GetItem write SetItem; - // for reporting - procedure WriteStr(AStream: TStream; const AText: string); - public type - TPairEnumerator = class(TAVLTreeEnumerator) - protected - function GetCurrent: TTreePair; override; - end; - - TNodeEnumerator = class(TAVLTreeEnumerator) - protected - function GetCurrent: PNode; override; - end; - - TKeyEnumerator = class(TAVLTreeEnumerator) - protected - function GetCurrent: TKey; override; - end; - - TPKeyEnumerator = class(TAVLTreeEnumerator) - protected - function GetCurrent: PKey; override; - end; - - TValueEnumerator = class(TAVLTreeEnumerator) - protected - function GetCurrent: TValue; override; - end; - - TPValueEnumerator = class(TAVLTreeEnumerator) - protected - function GetCurrent: PValue; override; - end; - - TNodeCollection = class(TTreeEnumerable) - private - property Ptr; // PPNode has no sense, so hide enumerator for PPNode - end; - - TKeyCollection = class(TTreeEnumerable); - - TValueCollection = class(TTreeEnumerable); - private - FNodes: TNodeCollection; - function GetNodeCollection: TNodeCollection; - procedure InternalAdd(ANode, AParent: PNode); overload; - function InternalAdd(ANode: PNode; ADispisable: boolean): PNode; overload; - procedure InternalDelete(ANode: PNode); - function GetKeys: TKeyCollection; - function GetValues: TValueCollection; - public - constructor Create; virtual; overload; - constructor Create(const AComparer: IComparer); virtual; overload; - - function NewNode: PNode; - function NewNodeArray(ACount: SizeInt): PNode; overload; - procedure NewNodeArray(out AArray: TArray; ACount: SizeInt); overload; - procedure DisposeNode(ANode: PNode); - procedure DisposeNodeArray(ANode: PNode; ACount: SizeInt); overload; - procedure DisposeNodeArray(var AArray: TArray); overload; - - destructor Destroy; override; - function AddNode(ANode: PNode): boolean; overload; inline; - function AddNodeArray(const AArray: TArray): boolean; overload; inline; - function Add(constref APair: TTreePair): PNode; overload; inline; - function Add(constref AKey: TKey; constref AValue: TValue): PNode; overload; inline; - function Remove(constref AKey: TKey; ADisposeNode: boolean = true): boolean; - function ExtractPair(constref AKey: TKey; ADisposeNode: boolean = true): TTreePair; overload; - function ExtractPair(constref ANode: PNode; ADispose: boolean = true): TTreePair; overload; - function Extract(constref AKey: TKey; ADisposeNode: boolean): PNode; - function ExtractNode(ANode: PNode; ADispose: boolean): PNode; - function ExtractNodeArray(const AArray: TArray; ADispose: boolean): TArray; overload; - procedure Delete(ANode: PNode; ADispose: boolean = true); inline; - procedure DeleteArray(const AArray: TArray; ADispose: boolean = true); inline; - - function GetEnumerator: TPairEnumerator; - property Nodes: TNodeCollection read GetNodeCollection; - - procedure Clear(ADisposeNodes: Boolean = true); virtual; - - function FindLowest: PNode; - function FindHighest: PNode; - - property Count: SizeInt read FCount; - - property Root: PNode read FRoot; - function Find(constref AKey: TKey): PNode; - function ContainsKey(constref AKey: TKey; out ANode: PNode): boolean; overload; inline; - function ContainsKey(constref AKey: TKey): boolean; overload; inline; - - procedure ConsistencyCheck; virtual; - procedure WriteTreeNode(AStream: TStream; ANode: PNode); - procedure WriteReportToStream(AStream: TStream); - function NodeToReportStr(ANode: PNode): string; virtual; - function ReportAsString: string; - - property Keys: TKeyCollection read GetKeys; - property Values: TValueCollection read GetValues; - property Duplicates: TDuplicates read FDuplicates write FDuplicates; - - property OnNodeNotify: TNodeNotifyEvent read FOnNodeNotify write FOnNodeNotify; - property OnKeyNotify: TCollectionNotifyEvent read FOnKeyNotify write FOnKeyNotify; - property OnValueNotify: TCollectionNotifyEvent read FOnValueNotify write FOnValueNotify; - end; - - TAVLTreeMap = class(TCustomAVLTreeMap) - public - property Items; default; - end; - - TIndexedAVLTreeMap = class(TCustomAVLTreeMap) - protected - FLastNode: PNode; - FLastIndex: SizeInt; - - procedure RotateRightRight(ANode: PNode); override; - procedure RotateLeftLeft(ANode: PNode); override; - procedure RotateRightLeft(ANode: PNode); override; - procedure RotateLeftRight(ANode: PNode); override; - - procedure NodeAdded(ANode: PNode); override; - procedure DeletingNode(ANode: PNode; AOrigin: boolean); override; - public - function GetNodeAtIndex(AIndex: SizeInt): PNode; - function NodeToIndex(ANode: PNode): SizeInt; - - procedure ConsistencyCheck; override; - function NodeToReportStr(ANode: PNode): string; override; - end; - - TAVLTree = class(TAVLTreeMap) - protected - property OnKeyNotify; - property OnValueNotify; - property Items; - public type - TItemEnumerator = TKeyEnumerator; - public - function Add(constref AValue: T): PNode; reintroduce; inline; - function AddNode(ANode: PNode): boolean; reintroduce; inline; - - property OnNotify: TCollectionNotifyEvent read FOnKeyNotify write FOnKeyNotify; - end; - - TIndexedAVLTree = class(TIndexedAVLTreeMap) - protected - property OnKeyNotify; - property OnValueNotify; - public type - TItemEnumerator = TKeyEnumerator; - public - function Add(constref AValue: T): PNode; reintroduce; inline; - function AddNode(ANode: PNode): boolean; reintroduce; inline; - - property OnNotify: TCollectionNotifyEvent read FOnKeyNotify write FOnKeyNotify; - end; - - TSortedSet = class(TCustomSet) - private - procedure InternalAVLTreeNotify(ASender: TObject; constref AItem: T; AAction: TCollectionNotification); - protected - FInternalTree: TAVLTree; - public type - TSortedSetEnumerator = class(TCustomSetEnumerator) - protected type - TTreeEnumerator = TAVLTree.TItemEnumerator; - function GetCurrent: T; override; - public - constructor Create(ASet: TCustomSet); override; - end; - - TPointersEnumerator = class(TCustomPointersEnumerator) - protected - FEnumerator: TEnumerator; - function DoMoveNext: boolean; override; - function DoGetCurrent: PT; override; - public - constructor Create(ASortedSet: TSortedSet); - end; - protected - function GetPtrEnumerator: TEnumerator; override; - function GetCount: SizeInt; override; - function GetCapacity: SizeInt; override; - procedure SetCapacity(AValue: SizeInt); override; - function GetOnNotify: TCollectionNotifyEvent; override; - procedure SetOnNotify(AValue: TCollectionNotifyEvent); override; - public - constructor Create; override; overload; - constructor Create(const AComparer: IComparer); virtual; overload; - destructor Destroy; override; - function GetEnumerator: TCustomSetEnumerator; override; - - function Add(constref AValue: T): Boolean; override; - function Remove(constref AValue: T): Boolean; override; - function Extract(constref AValue: T): T; override; - procedure Clear; override; - function Contains(constref AValue: T): Boolean; override; - - procedure TrimExcess; override; - end; - - TSortedHashSet = class(TCustomSet) - private - procedure InternalDictionaryNotify(ASender: TObject; constref AItem: PT; AAction: TCollectionNotification); - protected - FInternalDictionary: TOpenAddressingLP; - FInternalTree: TAVLTree; - function DoGetEnumerator: TEnumerator; override; - function GetCount: SizeInt; override; - function GetCapacity: SizeInt; override; - procedure SetCapacity(AValue: SizeInt); override; - function GetOnNotify: TCollectionNotifyEvent; override; - procedure SetOnNotify(AValue: TCollectionNotifyEvent); override; - protected type - TSortedHashSetEqualityComparer = class(TInterfacedObject, IEqualityComparer) - private - FComparer: IComparer; - FEqualityComparer: IEqualityComparer; - function Equals(constref ALeft, ARight: PT): Boolean; - function GetHashCode(constref AValue: PT): UInt32; - public - constructor Create(const AComparer: IComparer); overload; - constructor Create(const AEqualityComparer: IEqualityComparer); overload; - constructor Create(const AComparer: IComparer; const AEqualityComparer: IEqualityComparer); overload; - end; - public type - TSortedHashSetEnumerator = class(TCustomSetEnumerator) - protected type - TTreeEnumerator = TAVLTree.TItemEnumerator; - function GetCurrent: T; override; - public - constructor Create(ASet: TCustomSet); override; - end; - - TPointersEnumerator = class(TCustomPointersEnumerator) - protected - FEnumerator: TEnumerator; - function DoMoveNext: boolean; override; - function DoGetCurrent: PT; override; - public - constructor Create(ASortedHashSet: TSortedHashSet); - end; - protected - function GetPtrEnumerator: TEnumerator; override; - public - constructor Create; override; overload; - constructor Create(const AComparer: IEqualityComparer); overload; - constructor Create(const AComparer: IComparer); overload; - constructor Create(const AComparer: IComparer; const AEqualityComparer: IEqualityComparer); overload; - destructor Destroy; override; - function GetEnumerator: TCustomSetEnumerator; override; - - function Add(constref AValue: T): Boolean; override; - function Remove(constref AValue: T): Boolean; override; - function Extract(constref AValue: T): T; override; - function PeekPtr(constref AValue: T): PT; - procedure Clear; override; - function Contains(constref AValue: T): Boolean; override; - - procedure TrimExcess; override; - end; - -function InCircularRange(ABottom, AItem, ATop: SizeInt): Boolean; - -var - EmptyRecord: TEmptyRecord; - -implementation - -function InCircularRange(ABottom, AItem, ATop: SizeInt): Boolean; -begin - Result := - (ABottom < AItem) and (AItem <= ATop ) - or (ATop < ABottom) and (AItem > ABottom) - or (ATop < ABottom ) and (AItem <= ATop ); -end; - -{ TCustomArrayHelper } - -class function TCustomArrayHelper.BinarySearch(constref AValues: array of T; constref AItem: T; - out AFoundIndex: SizeInt; const AComparer: IComparer): Boolean; -begin - Result := BinarySearch(AValues, AItem, AFoundIndex, AComparer, Low(AValues), Length(AValues)); -end; - -class function TCustomArrayHelper.BinarySearch(constref AValues: array of T; constref AItem: T; - out AFoundIndex: SizeInt): Boolean; -begin - Result := BinarySearch(AValues, AItem, AFoundIndex, TComparerBugHack.Default, Low(AValues), Length(AValues)); -end; - -class function TCustomArrayHelper.BinarySearch(constref AValues: array of T; constref AItem: T; - out ASearchResult: TBinarySearchResult; const AComparer: IComparer): Boolean; -begin - Result := BinarySearch(AValues, AItem, ASearchResult, AComparer, Low(AValues), Length(AValues)); -end; - -class function TCustomArrayHelper.BinarySearch(constref AValues: array of T; constref AItem: T; - out ASearchResult: TBinarySearchResult): Boolean; -begin - Result := BinarySearch(AValues, AItem, ASearchResult, TComparerBugHack.Default, Low(AValues), Length(AValues)); -end; - -class procedure TCustomArrayHelper.Sort(var AValues: array of T); -begin - QuickSort(AValues, Low(AValues), High(AValues), TComparerBugHack.Default); -end; - -class procedure TCustomArrayHelper.Sort(var AValues: array of T; - const AComparer: IComparer); -begin - QuickSort(AValues, Low(AValues), High(AValues), AComparer); -end; - -class procedure TCustomArrayHelper.Sort(var AValues: array of T; - const AComparer: IComparer; AIndex, ACount: SizeInt); -begin - if ACount <= 1 then - Exit; - QuickSort(AValues, AIndex, Pred(AIndex + ACount), AComparer); -end; - -{ TArrayHelper } - -class procedure TArrayHelper.QuickSort(var AValues: array of T; ALeft, ARight: SizeInt; - const AComparer: IComparer); -var - I, J: SizeInt; - P, Q: T; -begin - if ((ARight - ALeft) <= 0) or (Length(AValues) = 0) then - Exit; - repeat - I := ALeft; - J := ARight; - P := AValues[ALeft + (ARight - ALeft) shr 1]; - repeat - while AComparer.Compare(AValues[I], P) < 0 do - Inc(I); - while AComparer.Compare(AValues[J], P) > 0 do - Dec(J); - if I <= J then - begin - if I <> J then - begin - Q := AValues[I]; - AValues[I] := AValues[J]; - AValues[J] := Q; - end; - Inc(I); - Dec(J); - end; - until I > J; - // sort the smaller range recursively - // sort the bigger range via the loop - // Reasons: memory usage is O(log(n)) instead of O(n) and loop is faster than recursion - if J - ALeft < ARight - I then - begin - if ALeft < J then - QuickSort(AValues, ALeft, J, AComparer); - ALeft := I; - end - else - begin - if I < ARight then - QuickSort(AValues, I, ARight, AComparer); - ARight := J; - end; - until ALeft >= ARight; -end; - -class function TArrayHelper.BinarySearch(constref AValues: array of T; constref AItem: T; - out ASearchResult: TBinarySearchResult; const AComparer: IComparer; - AIndex, ACount: SizeInt): Boolean; -var - imin, imax, imid: Int32; -begin - // continually narrow search until just one element remains - imin := AIndex; - imax := Pred(AIndex + ACount); - - // http://en.wikipedia.org/wiki/Binary_search_algorithm - while (imin < imax) do - begin - imid := imin + ((imax - imin) shr 1); - - // code must guarantee the interval is reduced at each iteration - // assert(imid < imax); - // note: 0 <= imin < imax implies imid will always be less than imax - - ASearchResult.CompareResult := AComparer.Compare(AValues[imid], AItem); - // reduce the search - if (ASearchResult.CompareResult < 0) then - imin := imid + 1 - else - begin - imax := imid; - if ASearchResult.CompareResult = 0 then - begin - ASearchResult.FoundIndex := imid; - ASearchResult.CandidateIndex := imid; - Exit(True); - end; - end; - end; - // At exit of while: - // if A[] is empty, then imax < imin - // otherwise imax == imin - - // deferred test for equality - - if (imax = imin) then - begin - ASearchResult.CompareResult := AComparer.Compare(AValues[imin], AItem); - ASearchResult.CandidateIndex := imin; - if (ASearchResult.CompareResult = 0) then - begin - ASearchResult.FoundIndex := imin; - Exit(True); - end else - begin - ASearchResult.FoundIndex := -1; - Exit(False); - end; - end - else - begin - ASearchResult.CompareResult := 0; - ASearchResult.FoundIndex := -1; - ASearchResult.CandidateIndex := -1; - Exit(False); - end; -end; - -class function TArrayHelper.BinarySearch(constref AValues: array of T; constref AItem: T; - out AFoundIndex: SizeInt; const AComparer: IComparer; - AIndex, ACount: SizeInt): Boolean; -var - imin, imax, imid: Int32; - LCompare: SizeInt; -begin - // continually narrow search until just one element remains - imin := AIndex; - imax := Pred(AIndex + ACount); - - // http://en.wikipedia.org/wiki/Binary_search_algorithm - while (imin < imax) do - begin - imid := imin + ((imax - imin) shr 1); - - // code must guarantee the interval is reduced at each iteration - // assert(imid < imax); - // note: 0 <= imin < imax implies imid will always be less than imax - - LCompare := AComparer.Compare(AValues[imid], AItem); - // reduce the search - if (LCompare < 0) then - imin := imid + 1 - else - begin - imax := imid; - if LCompare = 0 then - begin - AFoundIndex := imid; - Exit(True); - end; - end; - end; - // At exit of while: - // if A[] is empty, then imax < imin - // otherwise imax == imin - - // deferred test for equality - - LCompare := AComparer.Compare(AValues[imin], AItem); - if (imax = imin) and (LCompare = 0) then - begin - AFoundIndex := imin; - Exit(True); - end - else - begin - AFoundIndex := -1; - Exit(False); - end; -end; - -{ TEnumerator } - -function TEnumerator.MoveNext: boolean; -begin - Exit(DoMoveNext); -end; - -{ TEnumerable } - -function TEnumerable.ToArrayImpl(ACount: SizeInt): TArray; -var - i: SizeInt; - LEnumerator: TEnumerator; -begin - SetLength(Result, ACount); - - try - LEnumerator := GetEnumerator; - - i := 0; - while LEnumerator.MoveNext do - begin - Result[i] := LEnumerator.Current; - Inc(i); - end; - finally - LEnumerator.Free; - end; -end; - -function TEnumerable.GetEnumerator: TEnumerator; -begin - Exit(DoGetEnumerator); -end; - -function TEnumerable.ToArray: TArray; -var - LEnumerator: TEnumerator; - LBuffer: TList; -begin - LBuffer := TList.Create; - try - LEnumerator := GetEnumerator; - - while LEnumerator.MoveNext do - LBuffer.Add(LEnumerator.Current); - - Result := LBuffer.ToArray; - finally - LBuffer.Free; - LEnumerator.Free; - end; -end; - -{ TCustomPointersCollection } - -function TCustomPointersCollection.Enumerable: TLocalEnumerable; -begin - Result := TLocalEnumerable(@Self); -end; - -function TCustomPointersCollection.GetEnumerator: TEnumerator; -begin - Result := Enumerable.GetPtrEnumerator; -end; - -{ TEnumerableWithPointers } - -function TEnumerableWithPointers.GetPtr: PPointersCollection; -begin - Result := PPointersCollection(Self); -end; - -{ TCustomList } - -function TCustomList.PrepareAddingItem: SizeInt; -begin - Result := Length(FItems); - - if (FLength < 4) and (Result < 4) then - SetLength(FItems, 4) - else if FLength = High(FLength) then - OutOfMemoryError - else if FLength = Result then - SetLength(FItems, CUSTOM_LIST_CAPACITY_INC); - - Result := FLength; - Inc(FLength); -end; - -function TCustomList.PrepareAddingRange(ACount: SizeInt): SizeInt; -begin - if ACount < 0 then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - if ACount = 0 then - Exit(FLength - 1); - - if (FLength = 0) and (Length(FItems) = 0) then - SetLength(FItems, 4) - else if FLength = High(FLength) then - OutOfMemoryError; - - Result := Length(FItems); - while Pred(FLength + ACount) >= Result do - begin - SetLength(FItems, CUSTOM_LIST_CAPACITY_INC); - Result := Length(FItems); - end; - - Result := FLength; - Inc(FLength, ACount); -end; - -function TCustomList.ToArray: TArray; -begin - Result := ToArrayImpl(Count); -end; - -function TCustomList.GetCount: SizeInt; -begin - Result := FLength; -end; - -procedure TCustomList.Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); -begin - if Assigned(FOnNotify) then - FOnNotify(Self, AValue, ACollectionNotification); -end; - -function TCustomList.DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): T; -begin - if (AIndex < 0) or (AIndex >= FLength) then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - Result := FItems[AIndex]; - Dec(FLength); - - FItems[AIndex] := Default(T); - if AIndex <> FLength then - begin - System.Move(FItems[AIndex + 1], FItems[AIndex], (FLength - AIndex) * SizeOf(T)); - FillChar(FItems[FLength], SizeOf(T), 0); - end; - - Notify(Result, ACollectionNotification); -end; - -function TCustomList.GetCapacity: SizeInt; -begin - Result := Length(FItems); -end; - -{ TCustomListEnumerator } - -function TCustomListEnumerator.DoMoveNext: boolean; -begin - Inc(FIndex); - Result := (FList.FLength <> 0) and (FIndex < FList.FLength) -end; - -function TCustomListEnumerator.DoGetCurrent: T; -begin - Result := GetCurrent; -end; - -function TCustomListEnumerator.GetCurrent: T; -begin - Result := FList.FItems[FIndex]; -end; - -constructor TCustomListEnumerator.Create(AList: TCustomList); -begin - inherited Create; - FIndex := -1; - FList := AList; -end; - -{ TCustomListWithPointers.TPointersEnumerator } - -function TCustomListWithPointers.TPointersEnumerator.DoMoveNext: boolean; -begin - Inc(FIndex); - Result := (FList.FLength <> 0) and (FIndex < FList.FLength) -end; - -function TCustomListWithPointers.TPointersEnumerator.DoGetCurrent: PT; -begin - Result := @FList.FItems[FIndex];; -end; - -constructor TCustomListWithPointers.TPointersEnumerator.Create(AList: TCustomListWithPointers); -begin - inherited Create; - FIndex := -1; - FList := AList; -end; - -{ TCustomListWithPointers } - -function TCustomListWithPointers.GetPtrEnumerator: TEnumerator; -begin - Result := TPointersEnumerator.Create(Self); -end; - -{ TList } - -procedure TList.InitializeList; -begin -end; - -constructor TList.Create; -begin - InitializeList; - FComparer := TComparer.Default; -end; - -constructor TList.Create(const AComparer: IComparer); -begin - InitializeList; - FComparer := AComparer; -end; - -constructor TList.Create(ACollection: TEnumerable); -var - LItem: T; -begin - Create; - for LItem in ACollection do - Add(LItem); -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -constructor TList.Create(ACollection: TEnumerableWithPointers); -var - LItem: PT; -begin - Create; - for LItem in ACollection.Ptr^ do - Add(LItem^); -end; -{$ENDIF} - -destructor TList.Destroy; -begin - SetCapacity(0); -end; - -procedure TList.SetCapacity(AValue: SizeInt); -begin - if AValue < Count then - Count := AValue; - - SetLength(FItems, AValue); -end; - -procedure TList.SetCount(AValue: SizeInt); -begin - if AValue < 0 then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - if AValue > Capacity then - Capacity := AValue; - if AValue < Count then - DeleteRange(AValue, Count - AValue); - - FLength := AValue; -end; - -function TList.GetItem(AIndex: SizeInt): T; -begin - if (AIndex < 0) or (AIndex >= Count) then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - Result := FItems[AIndex]; -end; - -procedure TList.SetItem(AIndex: SizeInt; const AValue: T); -begin - if (AIndex < 0) or (AIndex >= Count) then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - Notify(FItems[AIndex], cnRemoved); - FItems[AIndex] := AValue; - Notify(AValue, cnAdded); -end; - -function TList.GetEnumerator: TEnumerator; -begin - Result := TEnumerator.Create(Self); -end; - -function TList.DoGetEnumerator: {Generics.Collections.}TEnumerator; -begin - Result := GetEnumerator; -end; - -function TList.Add(constref AValue: T): SizeInt; -begin - Result := PrepareAddingItem; - FItems[Result] := AValue; - Notify(AValue, cnAdded); -end; - -procedure TList.AddRange(constref AValues: array of T); -begin - InsertRange(Count, AValues); -end; - -procedure TList.AddRange(const AEnumerable: IEnumerable); -var - LValue: T; -begin - for LValue in AEnumerable do - Add(LValue); -end; - -procedure TList.AddRange(AEnumerable: TEnumerable); -var - LValue: T; -begin - for LValue in AEnumerable do - Add(LValue); -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -procedure TList.AddRange(AEnumerable: TEnumerableWithPointers); -var - LValue: PT; -begin - for LValue in AEnumerable.Ptr^ do - Add(LValue^); -end; -{$ENDIF} - -procedure TList.InternalInsert(AIndex: SizeInt; constref AValue: T); -begin - if AIndex <> PrepareAddingItem then - begin - System.Move(FItems[AIndex], FItems[AIndex + 1], ((Count - AIndex) - 1) * SizeOf(T)); - FillChar(FItems[AIndex], SizeOf(T), 0); - end; - - FItems[AIndex] := AValue; - Notify(AValue, cnAdded); -end; - -procedure TList.Insert(AIndex: SizeInt; constref AValue: T); -begin - if (AIndex < 0) or (AIndex > Count) then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - InternalInsert(AIndex, AValue); -end; - -procedure TList.InsertRange(AIndex: SizeInt; constref AValues: array of T); -var - i: SizeInt; - LLength: SizeInt; - LValue: ^T; -begin - if (AIndex < 0) or (AIndex > Count) then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - LLength := Length(AValues); - if LLength = 0 then - Exit; - - if AIndex <> PrepareAddingRange(LLength) then - begin - System.Move(FItems[AIndex], FItems[AIndex + LLength], ((Count - AIndex) - LLength) * SizeOf(T)); - FillChar(FItems[AIndex], SizeOf(T) * LLength, 0); - end; - - LValue := @AValues[0]; - for i := AIndex to Pred(AIndex + LLength) do - begin - FItems[i] := LValue^; - Notify(LValue^, cnAdded); - Inc(LValue); - end; -end; - -procedure TList.InsertRange(AIndex: SizeInt; const AEnumerable: IEnumerable); -var - LValue: T; - i: SizeInt; -begin - if (AIndex < 0) or (AIndex > Count) then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - i := 0; - for LValue in AEnumerable do - begin - InternalInsert(Aindex + i, LValue); - Inc(i); - end; -end; - -procedure TList.InsertRange(AIndex: SizeInt; const AEnumerable: TEnumerable); -var - LValue: T; - i: SizeInt; -begin - if (AIndex < 0) or (AIndex > Count) then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - i := 0; - for LValue in AEnumerable do - begin - InternalInsert(Aindex + i, LValue); - Inc(i); - end; -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -procedure TList.InsertRange(AIndex: SizeInt; const AEnumerable: TEnumerableWithPointers); -var - LValue: PT; - i: SizeInt; -begin - if (AIndex < 0) or (AIndex > Count) then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - i := 0; - for LValue in AEnumerable.Ptr^ do - begin - InternalInsert(Aindex + i, LValue^); - Inc(i); - end; -end; -{$ENDIF} - -function TList.Remove(constref AValue: T): SizeInt; -begin - Result := IndexOf(AValue); - if Result >= 0 then - DoRemove(Result, cnRemoved); -end; - -procedure TList.Delete(AIndex: SizeInt); -begin - DoRemove(AIndex, cnRemoved); -end; - -procedure TList.DeleteRange(AIndex, ACount: SizeInt); -var - LDeleted: array of T; - i: SizeInt; - LMoveDelta: SizeInt; -begin - if ACount = 0 then - Exit; - - if (ACount < 0) or (AIndex < 0) or (AIndex + ACount > Count) then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - SetLength(LDeleted, ACount); - System.Move(FItems[AIndex], LDeleted[0], ACount * SizeOf(T)); - - LMoveDelta := Count - (AIndex + ACount); - - if LMoveDelta = 0 then - FillChar(FItems[AIndex], ACount * SizeOf(T), #0) - else - begin - System.Move(FItems[AIndex + ACount], FItems[AIndex], LMoveDelta * SizeOf(T)); - FillChar(FItems[Count - ACount], ACount * SizeOf(T), #0); - end; - - Dec(FLength, ACount); - - for i := 0 to High(LDeleted) do - Notify(LDeleted[i], cnRemoved); -end; - -function TList.ExtractIndex(const AIndex: SizeInt): T; -begin - Result := DoRemove(AIndex, cnExtracted); -end; - -function TList.Extract(constref AValue: T): T; -var - LIndex: SizeInt; -begin - LIndex := IndexOf(AValue); - if LIndex < 0 then - Exit(Default(T)); - - Result := DoRemove(LIndex, cnExtracted); -end; - -procedure TList.Exchange(AIndex1, AIndex2: SizeInt); -var - LTemp: T; -begin - LTemp := FItems[AIndex1]; - FItems[AIndex1] := FItems[AIndex2]; - FItems[AIndex2] := LTemp; -end; - -procedure TList.Move(AIndex, ANewIndex: SizeInt); -var - LTemp: T; -begin - if ANewIndex = AIndex then - Exit; - - if (ANewIndex < 0) or (ANewIndex >= Count) then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - LTemp := FItems[AIndex]; - FItems[AIndex] := Default(T); - - if AIndex < ANewIndex then - System.Move(FItems[Succ(AIndex)], FItems[AIndex], (ANewIndex - AIndex) * SizeOf(T)) - else - System.Move(FItems[ANewIndex], FItems[Succ(ANewIndex)], (AIndex - ANewIndex) * SizeOf(T)); - - FillChar(FItems[ANewIndex], SizeOf(T), #0); - FItems[ANewIndex] := LTemp; -end; - -function TList.First: T; -begin - Result := Items[0]; -end; - -function TList.Last: T; -begin - Result := Items[Pred(Count)]; -end; - -procedure TList.Clear; -begin - SetCount(0); - SetCapacity(0); -end; - -procedure TList.TrimExcess; -begin - SetCapacity(Count); -end; - -function TList.Contains(constref AValue: T): Boolean; -begin - Result := IndexOf(AValue) >= 0; -end; - -function TList.IndexOf(constref AValue: T): SizeInt; -var - i: SizeInt; -begin - for i := 0 to Count - 1 do - if FComparer.Compare(AValue, FItems[i]) = 0 then - Exit(i); - Result := -1; -end; - -function TList.LastIndexOf(constref AValue: T): SizeInt; -var - i: SizeInt; -begin - for i := Count - 1 downto 0 do - if FComparer.Compare(AValue, FItems[i]) = 0 then - Exit(i); - Result := -1; -end; - -procedure TList.Reverse; -var - a, b: SizeInt; - LTemp: T; -begin - a := 0; - b := Count - 1; - while a < b do - begin - LTemp := FItems[a]; - FItems[a] := FItems[b]; - FItems[b] := LTemp; - Inc(a); - Dec(b); - end; -end; - -procedure TList.Sort; -begin - TArrayHelperBugHack.Sort(FItems, FComparer, 0, Count); -end; - -procedure TList.Sort(const AComparer: IComparer); -begin - TArrayHelperBugHack.Sort(FItems, AComparer, 0, Count); -end; - -function TList.BinarySearch(constref AItem: T; out AIndex: SizeInt): Boolean; -begin - Result := TArrayHelperBugHack.BinarySearch(FItems, AItem, AIndex, FComparer, 0, Count); -end; - -function TList.BinarySearch(constref AItem: T; out AIndex: SizeInt; const AComparer: IComparer): Boolean; -begin - Result := TArrayHelperBugHack.BinarySearch(FItems, AItem, AIndex, AComparer, 0, Count); -end; - -{ TSortedList } - -procedure TSortedList.InitializeList; -begin - FSortStyle := cssAuto; -end; - -function TSortedList.Add(constref AValue: T): SizeInt; -var - LSearchResult: TBinarySearchResult; -begin - if SortStyle <> cssAuto then - Exit(inherited Add(AValue)); - if TArrayHelperBugHack.BinarySearch(FItems, AValue, LSearchResult, FComparer, 0, Count) then - case FDuplicates of - dupAccept: Result := LSearchResult.FoundIndex; - dupIgnore: Exit(LSearchResult.FoundIndex); - dupError: raise EListError.Create(SCollectionDuplicate); - end - else - begin - if LSearchResult.CandidateIndex = -1 then - Result := 0 - else - if LSearchResult.CompareResult > 0 then - Result := LSearchResult.CandidateIndex - else - Result := LSearchResult.CandidateIndex + 1; - end; - - InternalInsert(Result, AValue); -end; - -procedure TSortedList.Insert(AIndex: SizeInt; constref AValue: T); -begin - if FSortStyle = cssAuto then - raise EListError.Create(SSortedListError) - else - inherited; -end; - -procedure TSortedList.Exchange(AIndex1, AIndex2: SizeInt); -begin - if FSortStyle = cssAuto then - raise EListError.Create(SSortedListError) - else - inherited; -end; - -procedure TSortedList.Move(AIndex, ANewIndex: SizeInt); -begin - if FSortStyle = cssAuto then - raise EListError.Create(SSortedListError) - else - inherited; -end; - -procedure TSortedList.AddRange(constref AValues: array of T); -var - i: T; -begin - for i in AValues do - Add(i); -end; - -procedure TSortedList.InsertRange(AIndex: SizeInt; constref AValues: array of T); -var - LValue: T; - i: SizeInt; -begin - if (AIndex < 0) or (AIndex > Count) then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - i := 0; - for LValue in AValues do - begin - InternalInsert(AIndex + i, LValue); - Inc(i); - end; -end; - -function TSortedList.GetSorted: boolean; -begin - Result := FSortStyle in [cssAuto, cssUser]; -end; - -procedure TSortedList.SetSorted(AValue: boolean); -begin - if AValue then - SortStyle := cssAuto - else - SortStyle := cssNone; -end; - -procedure TSortedList.SetSortStyle(AValue: TCollectionSortStyle); -begin - if FSortStyle = AValue then - Exit; - if AValue = cssAuto then - Sort; - FSortStyle := AValue; -end; - -function TSortedList.ConsistencyCheck(ARaiseException: boolean = true): boolean; -var - i: Integer; - LCompare: SizeInt; -begin - if Sorted then - for i := 0 to Count-2 do - begin - LCompare := FComparer.Compare(FItems[i], FItems[i+1]); - if LCompare = 0 then - begin - if Duplicates <> dupAccept then - if ARaiseException then - raise EListError.Create(SCollectionDuplicate) - else - Exit(False) - end - else - if LCompare > 0 then - if ARaiseException then - raise EListError.Create(SCollectionInconsistency) - else - Exit(False) - end; - Result := True; -end; - -{ TThreadList } - -constructor TThreadList.Create; -begin - inherited Create; - FDuplicates:=dupIgnore; -{$ifdef FPC_HAS_FEATURE_THREADING} - InitCriticalSection(FLock); -{$endif} - FList := TList.Create; -end; - -destructor TThreadList.Destroy; -begin - LockList; - try - FList.Free; - inherited Destroy; - finally - UnlockList; -{$ifdef FPC_HAS_FEATURE_THREADING} - DoneCriticalSection(FLock); -{$endif} - end; -end; - -procedure TThreadList.Add(constref AValue: T); -begin - LockList; - try - if (Duplicates = dupAccept) or (FList.IndexOf(AValue) = -1) then - FList.Add(AValue) - else if Duplicates = dupError then - raise EArgumentException.CreateRes(@SDuplicatesNotAllowed); - finally - UnlockList; - end; -end; - -procedure TThreadList.Remove(constref AValue: T); -begin - LockList; - try - FList.Remove(AValue); - finally - UnlockList; - end; -end; - -procedure TThreadList.Clear; -begin - LockList; - try - FList.Clear; - finally - UnlockList; - end; -end; - -function TThreadList.LockList: TList; -begin - Result:=FList; -{$ifdef FPC_HAS_FEATURE_THREADING} - System.EnterCriticalSection(FLock); -{$endif} -end; - -procedure TThreadList.UnlockList; -begin -{$ifdef FPC_HAS_FEATURE_THREADING} - System.LeaveCriticalSection(FLock); -{$endif} -end; - -{ TQueue.TPointersEnumerator } - -function TQueue.TPointersEnumerator.DoMoveNext: boolean; -begin - Inc(FIndex); - Result := (FQueue.FLength <> 0) and (FIndex < FQueue.FLength) -end; - -function TQueue.TPointersEnumerator.DoGetCurrent: PT; -begin - Result := @FQueue.FItems[FIndex]; -end; - -constructor TQueue.TPointersEnumerator.Create(AQueue: TQueue); -begin - inherited Create; - FIndex := Pred(AQueue.FLow); - FQueue := AQueue; -end; - -{ TQueue.TEnumerator } - -constructor TQueue.TEnumerator.Create(AQueue: TQueue); -begin - inherited Create(AQueue); - - FIndex := Pred(AQueue.FLow); -end; - -{ TQueue } - -function TQueue.GetPtrEnumerator: TEnumerator; -begin - Result := TPointersenumerator.Create(Self); -end; - -function TQueue.GetEnumerator: TEnumerator; -begin - Result := TEnumerator.Create(Self); -end; - -function TQueue.DoGetEnumerator: {Generics.Collections.}TEnumerator; -begin - Result := GetEnumerator; -end; - -function TQueue.DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): T; -begin - Result := FItems[AIndex]; - FItems[AIndex] := Default(T); - Inc(FLow); - if FLow = FLength then - begin - FLow := 0; - FLength := 0; - end; - Notify(Result, ACollectionNotification); -end; - -procedure TQueue.SetCapacity(AValue: SizeInt); -begin - if AValue < Count then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - if AValue = FLength then - Exit; - - if (Count > 0) and (FLow > 0) then - begin - Move(FItems[FLow], FItems[0], Count * SizeOf(T)); - FillChar(FItems[Count], (FLength - Count) * SizeOf(T), #0); - end; - - SetLength(FItems, AValue); - FLength := Count; - FLow := 0; -end; - -function TQueue.GetCount: SizeInt; -begin - Result := FLength - FLow; -end; - -constructor TQueue.Create(ACollection: TEnumerable); -var - LItem: T; -begin - for LItem in ACollection do - Enqueue(LItem); -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -constructor TQueue.Create(ACollection: TEnumerableWithPointers); -var - LItem: PT; -begin - for LItem in ACollection.Ptr^ do - Enqueue(LItem^); -end; -{$ENDIF} - -destructor TQueue.Destroy; -begin - Clear; -end; - -procedure TQueue.Enqueue(constref AValue: T); -var - LIndex: SizeInt; -begin - LIndex := PrepareAddingItem; - FItems[LIndex] := AValue; - Notify(AValue, cnAdded); -end; - -function TQueue.Dequeue: T; -begin - Result := DoRemove(FLow, cnRemoved); -end; - -function TQueue.Extract: T; -begin - Result := DoRemove(FLow, cnExtracted); -end; - -function TQueue.Peek: T; -begin - if (Count = 0) then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - Result := FItems[FLow]; -end; - -procedure TQueue.Clear; -begin - while Count <> 0 do - Dequeue; - FLow := 0; - FLength := 0; -end; - -procedure TQueue.TrimExcess; -begin - SetCapacity(Count); -end; - -{ TStack } - -function TStack.GetEnumerator: TEnumerator; -begin - Result := TEnumerator.Create(Self); -end; - -function TStack.DoGetEnumerator: {Generics.Collections.}TEnumerator; -begin - Result := GetEnumerator; -end; - -constructor TStack.Create(ACollection: TEnumerable); -var - LItem: T; -begin - for LItem in ACollection do - Push(LItem); -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -constructor TStack.Create(ACollection: TEnumerableWithPointers); -var - LItem: PT; -begin - for LItem in ACollection.Ptr^ do - Push(LItem^); -end; -{$ENDIF} - -function TStack.DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): T; -begin - if AIndex < 0 then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - Result := FItems[AIndex]; - FItems[AIndex] := Default(T); - Dec(FLength); - Notify(Result, ACollectionNotification); -end; - -destructor TStack.Destroy; -begin - Clear; -end; - -procedure TStack.Clear; -begin - while Count <> 0 do - Pop; -end; - -procedure TStack.SetCapacity(AValue: SizeInt); -begin - if AValue < Count then - AValue := Count; - - SetLength(FItems, AValue); -end; - -procedure TStack.Push(constref AValue: T); -var - LIndex: SizeInt; -begin - LIndex := PrepareAddingItem; - FItems[LIndex] := AValue; - Notify(AValue, cnAdded); -end; - -function TStack.Pop: T; -begin - Result := DoRemove(FLength - 1, cnRemoved); -end; - -function TStack.Peek: T; -begin - if (Count = 0) then - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - - Result := FItems[FLength - 1]; -end; - -function TStack.Extract: T; -begin - Result := DoRemove(FLength - 1, cnExtracted); -end; - -procedure TStack.TrimExcess; -begin - SetCapacity(Count); -end; - -{ TObjectList } - -procedure TObjectList.Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); -begin - inherited Notify(AValue, ACollectionNotification); - - if FObjectsOwner and (ACollectionNotification = cnRemoved) then - TObject(AValue).Free; -end; - -constructor TObjectList.Create(AOwnsObjects: Boolean); -begin - inherited Create; - - FObjectsOwner := AOwnsObjects; -end; - -constructor TObjectList.Create(const AComparer: IComparer; AOwnsObjects: Boolean); -begin - inherited Create(AComparer); - - FObjectsOwner := AOwnsObjects; -end; - -constructor TObjectList.Create(ACollection: TEnumerable; AOwnsObjects: Boolean); -begin - inherited Create(ACollection); - - FObjectsOwner := AOwnsObjects; -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -constructor TObjectList.Create(ACollection: TEnumerableWithPointers; AOwnsObjects: Boolean); -begin - inherited Create(ACollection); - - FObjectsOwner := AOwnsObjects; -end; -{$ENDIF} - -{ TObjectQueue } - -procedure TObjectQueue.Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); -begin - inherited Notify(AValue, ACollectionNotification); - if FObjectsOwner and (ACollectionNotification = cnRemoved) then - TObject(AValue).Free; -end; - -constructor TObjectQueue.Create(AOwnsObjects: Boolean); -begin - inherited Create; - - FObjectsOwner := AOwnsObjects; -end; - -constructor TObjectQueue.Create(ACollection: TEnumerable; AOwnsObjects: Boolean); -begin - inherited Create(ACollection); - - FObjectsOwner := AOwnsObjects; -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -constructor TObjectQueue.Create(ACollection: TEnumerableWithPointers; AOwnsObjects: Boolean); -begin - inherited Create(ACollection); - - FObjectsOwner := AOwnsObjects; -end; -{$ENDIF} - -procedure TObjectQueue.Dequeue; -begin - inherited Dequeue; -end; - -{ TObjectStack } - -procedure TObjectStack.Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); -begin - inherited Notify(AValue, ACollectionNotification); - if FObjectsOwner and (ACollectionNotification = cnRemoved) then - TObject(AValue).Free; -end; - -constructor TObjectStack.Create(AOwnsObjects: Boolean); -begin - inherited Create; - - FObjectsOwner := AOwnsObjects; -end; - -constructor TObjectStack.Create(ACollection: TEnumerable; AOwnsObjects: Boolean); -begin - inherited Create(ACollection); - - FObjectsOwner := AOwnsObjects; -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -constructor TObjectStack.Create(ACollection: TEnumerableWithPointers; AOwnsObjects: Boolean); -begin - inherited Create(ACollection); - - FObjectsOwner := AOwnsObjects; -end; -{$ENDIF} - -function TObjectStack.Pop: T; -begin - Result := inherited Pop; -end; - -{$I inc\generics.dictionaries.inc} - -{ TCustomSet.TCustomSetEnumerator } - -function TCustomSet.TCustomSetEnumerator.DoMoveNext: boolean; -begin - Result := FEnumerator.DoMoveNext; -end; - -function TCustomSet.TCustomSetEnumerator.DoGetCurrent: T; -begin - Result := FEnumerator.DoGetCurrent; -end; - -destructor TCustomSet.TCustomSetEnumerator.Destroy; -begin - FEnumerator.Free; -end; - -{ TCustomSet } - -function TCustomSet.DoGetEnumerator: TEnumerator; -begin - Result := GetEnumerator; -end; - -constructor TCustomSet.Create(ACollection: TEnumerable); -var - i: T; -begin - Create; - for i in ACollection do - Add(i); -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -constructor TCustomSet.Create(ACollection: TEnumerableWithPointers); -var - i: PT; -begin - Create; - for i in ACollection.Ptr^ do - Add(i^); -end; -{$ENDIF} - -function TCustomSet.AddRange(constref AValues: array of T): Boolean; -var - i: T; -begin - Result := True; - for i in AValues do - Result := Add(i) and Result; -end; - -function TCustomSet.AddRange(const AEnumerable: IEnumerable): Boolean; -var - i: T; -begin - Result := True; - for i in AEnumerable do - Result := Add(i) and Result; -end; - -function TCustomSet.AddRange(AEnumerable: TEnumerable): Boolean; -var - i: T; -begin - Result := True; - for i in AEnumerable do - Result := Add(i) and Result; -end; - -{$IFDEF ENABLE_METHODS_WITH_TEnumerableWithPointers} -function TCustomSet.AddRange(AEnumerable: TEnumerableWithPointers): Boolean; -var - i: PT; -begin - Result := True; - for i in AEnumerable.Ptr^ do - Result := Add(i^) and Result; -end; -{$ENDIF} - -procedure TCustomSet.UnionWith(AHashSet: TCustomSet); -var - i: PT; -begin - for i in AHashSet.Ptr^ do - Add(i^); -end; - -procedure TCustomSet.IntersectWith(AHashSet: TCustomSet); -var - LList: TList; - i: PT; -begin - LList := TList.Create; - - for i in Ptr^ do - if not AHashSet.Contains(i^) then - LList.Add(i); - - for i in LList do - Remove(i^); - - LList.Free; -end; - -procedure TCustomSet.ExceptWith(AHashSet: TCustomSet); -var - i: PT; -begin - for i in AHashSet.Ptr^ do - Remove(i^); -end; - -procedure TCustomSet.SymmetricExceptWith(AHashSet: TCustomSet); -var - LList: TList; - i: PT; -begin - LList := TList.Create; - - for i in AHashSet.Ptr^ do - if Contains(i^) then - LList.Add(i) - else - Add(i^); - - for i in LList do - Remove(i^); - - LList.Free; -end; - -{ THashSet.THashSetEnumerator } - -function THashSet.THashSetEnumerator.GetCurrent: T; -begin - Result := TDictionaryEnumerator(FEnumerator).GetCurrent; -end; - -constructor THashSet.THashSetEnumerator.Create(ASet: TCustomSet); -begin - TDictionaryEnumerator(FEnumerator) := THashSet(ASet).FInternalDictionary.Keys.DoGetEnumerator; -end; - -{ THashSet.TPointersEnumerator } - -function THashSet.TPointersEnumerator.DoMoveNext: boolean; -begin - Result := FEnumerator.MoveNext; -end; - -function THashSet.TPointersEnumerator.DoGetCurrent: PT; -begin - Result := FEnumerator.Current; -end; - -constructor THashSet.TPointersEnumerator.Create(AHashSet: THashSet); -begin - FEnumerator := AHashSet.FInternalDictionary.Keys.Ptr^.GetEnumerator; -end; - -{ THashSet } - -procedure THashSet.InternalDictionaryNotify(ASender: TObject; constref AItem: T; AAction: TCollectionNotification); -begin - FOnNotify(Self, AItem, AAction); -end; - -function THashSet.GetPtrEnumerator: TEnumerator; -begin - Result := TPointersEnumerator.Create(Self); -end; - -function THashSet.GetCount: SizeInt; -begin - Result := FInternalDictionary.Count; -end; - -function THashSet.GetCapacity: SizeInt; -begin - Result := FInternalDictionary.Capacity; -end; - -procedure THashSet.SetCapacity(AValue: SizeInt); -begin - FInternalDictionary.Capacity := AValue; -end; - -function THashSet.GetOnNotify: TCollectionNotifyEvent; -begin - Result := FInternalDictionary.OnKeyNotify; -end; - -procedure THashSet.SetOnNotify(AValue: TCollectionNotifyEvent); -begin - FOnNotify := AValue; - if Assigned(AValue) then - FInternalDictionary.OnKeyNotify := InternalDictionaryNotify - else - FInternalDictionary.OnKeyNotify := nil; -end; - -function THashSet.GetEnumerator: TCustomSetEnumerator; -begin - Result := THashSetEnumerator.Create(Self); -end; - -constructor THashSet.Create; -begin - FInternalDictionary := TOpenAddressingLP.Create; -end; - -constructor THashSet.Create(const AComparer: IEqualityComparer); -begin - FInternalDictionary := TOpenAddressingLP.Create(AComparer); -end; - -destructor THashSet.Destroy; -begin - FInternalDictionary.Free; -end; - -function THashSet.Add(constref AValue: T): Boolean; -begin - Result := not FInternalDictionary.ContainsKey(AValue); - if Result then - FInternalDictionary.Add(AValue, EmptyRecord); -end; - -function THashSet.Remove(constref AValue: T): Boolean; -var - LIndex: SizeInt; -begin - LIndex := FInternalDictionary.FindBucketIndex(AValue); - Result := LIndex >= 0; - if Result then - FInternalDictionary.DoRemove(LIndex, cnRemoved); -end; - -function THashSet.Extract(constref AValue: T): T; -var - LIndex: SizeInt; -begin - LIndex := FInternalDictionary.FindBucketIndex(AValue); - if LIndex < 0 then - Exit(Default(T)); - - Result := AValue; - FInternalDictionary.DoRemove(LIndex, cnExtracted); -end; - -procedure THashSet.Clear; -begin - FInternalDictionary.Clear; -end; - -function THashSet.Contains(constref AValue: T): Boolean; -begin - Result := FInternalDictionary.ContainsKey(AValue); -end; - -procedure THashSet.TrimExcess; -begin - FInternalDictionary.TrimExcess; -end; - -{ TAVLTreeNode } - -function TAVLTreeNode.Successor: PNode; -begin - Result:=Right; - if Result<>nil then begin - while (Result.Left<>nil) do Result:=Result.Left; - end else begin - Result:=@Self; - while (Result.Parent<>nil) and (Result.Parent.Right=Result) do - Result:=Result.Parent; - Result:=Result.Parent; - end; -end; - -function TAVLTreeNode.Precessor: PNode; -begin - Result:=Left; - if Result<>nil then begin - while (Result.Right<>nil) do Result:=Result.Right; - end else begin - Result:=@Self; - while (Result.Parent<>nil) and (Result.Parent.Left=Result) do - Result:=Result.Parent; - Result:=Result.Parent; - end; -end; - -function TAVLTreeNode.TreeDepth: integer; -// longest WAY down. e.g. only one node => 0 ! -var LeftDepth, RightDepth: integer; -begin - if Left<>nil then - LeftDepth:=Left.TreeDepth+1 - else - LeftDepth:=0; - if Right<>nil then - RightDepth:=Right.TreeDepth+1 - else - RightDepth:=0; - if LeftDepth>RightDepth then - Result:=LeftDepth - else - Result:=RightDepth; -end; - -procedure TAVLTreeNode.ConsistencyCheck(ATree: TObject); -var - LTree: TTree absolute ATree; - LeftDepth: SizeInt; - RightDepth: SizeInt; -begin - // test left child - if Left<>nil then begin - if Left.Parent<>@Self then - raise EAVLTree.Create('Left.Parent<>Self'); - if LTree.Compare(Left.Data.Key,Data.Key)>0 then - raise EAVLTree.Create('Compare(Left.Data,Data)>0'); - Left.ConsistencyCheck(LTree); - end; - // test right child - if Right<>nil then begin - if Right.Parent<>@Self then - raise EAVLTree.Create('Right.Parent<>Self'); - if LTree.Compare(Data.Key,Right.Data.Key)>0 then - raise EAVLTree.Create('Compare(Data,Right.Data)>0'); - Right.ConsistencyCheck(LTree); - end; - // test balance - if Left<>nil then - LeftDepth:=Left.TreeDepth+1 - else - LeftDepth:=0; - if Right<>nil then - RightDepth:=Right.TreeDepth+1 - else - RightDepth:=0; - if Balance<>(LeftDepth-RightDepth) then - raise EAVLTree.CreateFmt('Balance[%d]<>(RightDepth[%d]-LeftDepth[%d])', [Balance, RightDepth, LeftDepth]); -end; - -function TAVLTreeNode.GetCount: SizeInt; -begin - Result:=1; - if Assigned(Left) then Inc(Result,Left.GetCount); - if Assigned(Right) then Inc(Result,Right.GetCount); -end; - -{ TCustomTreeEnumerator } - -function TCustomTreeEnumerator.DoGetCurrent: T; -begin - Result := GetCurrent; -end; - -constructor TCustomTreeEnumerator.Create(ATree: TObject); -begin - TObject(FTree) := ATree; -end; - -{ TTreeEnumerable } - -function TTreeEnumerable.GetCount: SizeInt; -begin - Result := FTree.Count; -end; - -function TTreeEnumerable.GetPtrEnumerator: TEnumerator; -begin - Result := TTreePointersEnumerator.Create(FTree); -end; - -constructor TTreeEnumerable.Create( - ATree: TTree); -begin - FTree := ATree; -end; - -function TTreeEnumerable. - DoGetEnumerator: TTreeEnumerator; -begin - Result := TTreeEnumerator.Create(FTree); -end; - -function TTreeEnumerable.ToArray: TArray; -begin - Result := ToArrayImpl(FTree.Count); -end; - -{ TAVLTreeEnumerator } - -function TAVLTreeEnumerator.DoMoveNext: Boolean; -begin - if FLowToHigh then begin - if FCurrent<>nil then - FCurrent:=FCurrent.Successor - else - FCurrent:=FTree.FindLowest; - end else begin - if FCurrent<>nil then - FCurrent:=FCurrent.Precessor - else - FCurrent:=FTree.FindHighest; - end; - Result:=FCurrent<>nil; -end; - -constructor TAVLTreeEnumerator.Create(ATree: TObject; ALowToHigh: boolean); -begin - inherited Create(ATree); - FLowToHigh:=aLowToHigh; -end; - -{ TCustomAVLTreeMap.TPairEnumerator } - -function TCustomAVLTreeMap.TPairEnumerator.GetCurrent: TTreePair; -begin - Result := TTreePair((@FCurrent.Data)^); -end; - -{ TCustomAVLTreeMap.TNodeEnumerator } - -function TCustomAVLTreeMap.TNodeEnumerator.GetCurrent: PNode; -begin - Result := FCurrent; -end; - -{ TCustomAVLTreeMap.TKeyEnumerator } - -function TCustomAVLTreeMap.TKeyEnumerator.GetCurrent: TKey; -begin - Result := FCurrent.Key; -end; - -{ TCustomAVLTreeMap.TPKeyEnumerator } - -function TCustomAVLTreeMap.TPKeyEnumerator.GetCurrent: PKey; -begin - Result := @FCurrent.Data.Key; -end; - -{ TCustomAVLTreeMap.TValueEnumerator } - -function TCustomAVLTreeMap.TValueEnumerator.GetCurrent: TValue; -begin - Result := FCurrent.Value; -end; - -{ TCustomAVLTreeMap.TValueEnumerator } - -function TCustomAVLTreeMap.TPValueEnumerator.GetCurrent: PValue; -begin - Result := @FCurrent.Data.Value; -end; - -{ TCustomAVLTreeMap } - -procedure TCustomAVLTreeMap.NodeAdded(ANode: PNode); -begin -end; - -procedure TCustomAVLTreeMap.DeletingNode(ANode: PNode; AOrigin: boolean); -begin -end; - -function TCustomAVLTreeMap.DoRemove(ANode: PNode; - ACollectionNotification: TCollectionNotification; ADispose: boolean): TValue; -begin - if ANode=nil then - raise EArgumentNilException.CreateRes(@SArgumentNilNode); - - if (ANode.Left = nil) or (ANode.Right = nil) then - DeletingNode(ANode, true); - - InternalDelete(ANode); - - Dec(FCount); - NodeNotify(ANode, ACollectionNotification, ADispose); - - if ADispose then - Dispose(ANode); -end; - -procedure TCustomAVLTreeMap.DisposeAllNodes(ANode: PNode); -begin - if ANode.Left<>nil then - DisposeAllNodes(ANode.Left); - if ANode.Right<>nil then - DisposeAllNodes(ANode.Right); - - NodeNotify(ANode, cnRemoved, true); - Dispose(ANode); -end; - -function TCustomAVLTreeMap.Compare(constref ALeft, ARight: TKey): Integer; inline; -begin - Result := FComparer.Compare(ALeft, ARight); -end; - -function TCustomAVLTreeMap.FindPredecessor(ANode: PNode): PNode; -begin - if ANode <> nil then - begin - if ANode.Left <> nil then - begin - ANode := ANode.Left; - while ANode.Right <> nil do ANode := ANode.Right; - end - else - repeat - Result := ANode; - ANode := ANode.Parent; - until (ANode = nil) or (ANode.Right = Result); - end; - Result := ANode; -end; - -function TCustomAVLTreeMap.FindInsertNode(ANode: PNode; out AInsertNode: PNode): Integer; -begin - AInsertNode := FRoot; - if AInsertNode = nil then // first item in tree - Exit(0); - - repeat - Result := Compare(ANode.Key,AInsertNode.Key); - if Result < 0 then - begin - Result:=-1; - if AInsertNode.Left = nil then - Exit; - AInsertNode := AInsertNode.Left; - end - else - begin - if Result > 0 then - Result:=1; - if AInsertNode.Right = nil then - Exit; - AInsertNode := AInsertNode.Right; - if Result = 0 then - Break; - end; - until false; - - // for equal items (when item already exist) we need to keep 0 result - while true do - if Compare(ANode.Key,AInsertNode.Key) < 0 then - begin - if AInsertNode.Left = nil then - Exit; - AInsertNode := AInsertNode.Left; - end - else - begin - if AInsertNode.Right = nil then - Exit; - AInsertNode := AInsertNode.Right; - end; -end; - -procedure TCustomAVLTreeMap.RotateRightRight(ANode: PNode); -var - LNode, LParent: PNode; -begin - LNode := ANode.Right; - LParent := ANode.Parent; - - ANode.Right := LNode.Left; - if ANode.Right <> nil then - ANode.Right.Parent := ANode; - - LNode.Left := ANode; - LNode.Parent := LParent; - ANode.Parent := LNode; - - if LParent <> nil then - begin - if LParent.Left = ANode then - LParent.Left := LNode - else - LParent.Right := LNode; - end - else - FRoot := LNode; - - if LNode.Balance = -1 then - begin - ANode.Balance := 0; - LNode.Balance := 0; - end - else - begin - ANode.Balance := -1; - LNode.Balance := 1; - end -end; - -procedure TCustomAVLTreeMap.RotateLeftLeft(ANode: PNode); -var - LNode, LParent: PNode; -begin - LNode := ANode.Left; - LParent := ANode.Parent; - - ANode.Left := LNode.Right; - if ANode.Left <> nil then - ANode.Left.Parent := ANode; - - LNode.Right := ANode; - LNode.Parent := LParent; - ANode.Parent := LNode; - - if LParent <> nil then - begin - if LParent.Left = ANode then - LParent.Left := LNode - else - LParent.Right := LNode; - end - else - FRoot := LNode; - - if LNode.Balance = 1 then - begin - ANode.Balance := 0; - LNode.Balance := 0; - end - else - begin - ANode.Balance := 1; - LNode.Balance := -1; - end -end; - -procedure TCustomAVLTreeMap.RotateRightLeft(ANode: PNode); -var - LRight, LLeft, LParent: PNode; -begin - LRight := ANode.Right; - LLeft := LRight.Left; - LParent := ANode.Parent; - - LRight.Left := LLeft.Right; - if LRight.Left <> nil then - LRight.Left.Parent := LRight; - - ANode.Right := LLeft.Left; - if ANode.Right <> nil then - ANode.Right.Parent := ANode; - - LLeft.Left := ANode; - LLeft.Right := LRight; - ANode.Parent := LLeft; - LRight.Parent := LLeft; - - LLeft.Parent := LParent; - - if LParent <> nil then - begin - if LParent.Left = ANode then - LParent.Left := LLeft - else - LParent.Right := LLeft; - end - else - FRoot := LLeft; - - if LLeft.Balance = -1 then - ANode.Balance := 1 - else - ANode.Balance := 0; - - if LLeft.Balance = 1 then - LRight.Balance := -1 - else - LRight.Balance := 0; - - LLeft.Balance := 0; -end; - -procedure TCustomAVLTreeMap.RotateLeftRight(ANode: PNode); -var - LLeft, LRight, LParent: PNode; -begin - LLeft := ANode.Left; - LRight := LLeft.Right; - LParent := ANode.Parent; - - LLeft.Right := LRight.Left; - if LLeft.Right <> nil then - LLeft.Right.Parent := LLeft; - - ANode.Left := LRight.Right; - if ANode.Left <> nil then - ANode.Left.Parent := ANode; - - LRight.Right := ANode; - LRight.Left := LLeft; - ANode.Parent := LRight; - LLeft.Parent := LRight; - - LRight.Parent := LParent; - - if LParent <> nil then - begin - if LParent.Left = ANode then - LParent.Left := LRight - else - LParent.Right := LRight; - end - else - FRoot := LRight; - - if LRight.Balance = 1 then - ANode.Balance := -1 - else - ANode.Balance := 0; - if LRight.Balance = -1 then - LLeft.Balance := 1 - else - LLeft.Balance := 0; - - LRight.Balance := 0; -end; - -procedure TCustomAVLTreeMap.KeyNotify(constref AKey: TKey; ACollectionNotification: TCollectionNotification); -begin - if Assigned(FOnKeyNotify) then - FOnKeyNotify(Self, AKey, ACollectionNotification); -end; - -procedure TCustomAVLTreeMap.ValueNotify(constref AValue: TValue; ACollectionNotification: TCollectionNotification); -begin - if Assigned(FOnValueNotify) then - FOnValueNotify(Self, AValue, ACollectionNotification); -end; - -procedure TCustomAVLTreeMap.NodeNotify(ANode: PNode; ACollectionNotification: TCollectionNotification; ADispose: boolean); -begin - if Assigned(FOnValueNotify) then - FOnNodeNotify(Self, ANode, ACollectionNotification, ADispose); - KeyNotify(ANode.Key, ACollectionNotification); - ValueNotify(ANode.Value, ACollectionNotification); -end; - -procedure TCustomAVLTreeMap.SetValue(var AValue: TValue; constref ANewValue: TValue); -var - LOldValue: TValue; -begin - LOldValue := AValue; - AValue := ANewValue; - - ValueNotify(LOldValue, cnRemoved); - ValueNotify(ANewValue, cnAdded); -end; - -procedure TCustomAVLTreeMap.WriteStr(AStream: TStream; const AText: string); -begin - if AText='' then exit; - AStream.Write(AText[1],Length(AText)); -end; - -function TCustomAVLTreeMap.GetNodeCollection: TNodeCollection; -begin - if not Assigned(FNodes) then - FNodes := TNodeCollection.Create(TTree(Self)); - Result := FNodes; -end; - -procedure TCustomAVLTreeMap.InternalAdd(ANode, AParent: PNode); -begin - Inc(FCount); - - ANode.Parent := AParent; - NodeAdded(ANode); - - if AParent=nil then - begin - FRoot := ANode; - Exit; - end; - - // balance after insert - - if AParent.Balance<>0 then - AParent.Balance := 0 - else - begin - if AParent.Left = ANode then - AParent.Balance := 1 - else - AParent.Balance := -1; - - ANode := AParent.Parent; - - while ANode <> nil do - begin - if ANode.Balance<>0 then - begin - if ANode.Balance = 1 then - begin - if ANode.Right = AParent then - ANode.Balance := 0 - else if AParent.Balance = -1 then - RotateLeftRight(ANode) - else - RotateLeftLeft(ANode); - end - else - begin - if ANode.Left = AParent then - ANode.Balance := 0 - else if AParent^.Balance = 1 then - RotateRightLeft(ANode) - else - RotateRightRight(ANode); - end; - Break; - end; - - if ANode.Left = AParent then - ANode.Balance := 1 - else - ANode.Balance := -1; - - AParent := ANode; - ANode := ANode.Parent; - end; - end; -end; - -function TCustomAVLTreeMap.InternalAdd(ANode: PNode; ADispisable: boolean): PNode; -var - LParent: PNode; -begin - Result := ANode; - case FindInsertNode(ANode, LParent) of - -1: LParent.Left := ANode; - 0: - if Assigned(LParent) then - case FDuplicates of - dupAccept: LParent.Right := ANode; - dupIgnore: - begin - LParent.Right := nil; - if ADispisable then - Dispose(ANode); - Exit(LParent); - end; - dupError: - begin - LParent.Right := nil; - if ADispisable then - Dispose(ANode); - Result := nil; - raise EListError.Create(SCollectionDuplicate); - end; - end; - 1: LParent.Right := ANode; - end; - - InternalAdd(ANode, LParent); - NodeNotify(ANode, cnAdded, false); -end; - -procedure TCustomAVLTreeMap.InternalDelete(ANode: PNode); -var - t, y, z: PNode; - LNest: boolean; -begin - if (ANode.Left <> nil) and (ANode.Right <> nil) then - begin - y := FindPredecessor(ANode); - y.Info := ANode.Info; - DeletingNode(y, false); - InternalDelete(y); - LNest := false; - end - else - begin - if ANode.Left <> nil then - begin - y := ANode.Left; - ANode.Left := nil; - end - else - begin - y := ANode.Right; - ANode.Right := nil; - end; - ANode.Balance := 0; - LNest := true; - end; - - if y <> nil then - begin - y.Parent := ANode.Parent; - y.Left := ANode.Left; - if y.Left <> nil then - y.Left.Parent := y; - y.Right := ANode.Right; - if y.Right <> nil then - y.Right.Parent := y; - y.Balance := ANode.Balance; - end; - - if ANode.Parent <> nil then - begin - if ANode.Parent.Left = ANode then - ANode.Parent.Left := y - else - ANode.Parent.Right := y; - end - else - FRoot := y; - - if LNest then - begin - z := y; - y := ANode.Parent; - while y <> nil do - begin - if y.Balance = 0 then - begin - if y.Left = z then - y.Balance := -1 - else - y.Balance := 1; - break; - end - else - begin - if ((y.Balance = 1) and (y.Left = z)) or ((y.Balance = -1) and (y.Right = z)) then - begin - y.Balance := 0; - z := y; - y := y.Parent; - end - else - begin - if y.Left = z then - t := y.Right - else - t := y.Left; - if t.Balance = 0 then - begin - if y.Balance = 1 then - RotateLeftLeft(y) - else - RotateRightRight(y); - break; - end - else if y.Balance = t.Balance then - begin - if y.Balance = 1 then - RotateLeftLeft(y) - else - RotateRightRight(y); - z := t; - y := t.Parent; - end - else - begin - if y.Balance = 1 then - RotateLeftRight(y) - else - RotateRightLeft(y); - z := y.Parent; - y := z.Parent; - end - end - end - end - end; -end; - -function TCustomAVLTreeMap.GetKeys: TKeyCollection; -begin - if not Assigned(FKeys) then - FKeys := TKeyCollection.Create(TTree(Self)); - Result := TKeyCollection(FKeys); -end; - -function TCustomAVLTreeMap.GetValues: TValueCollection; -begin - if not Assigned(FValues) then - FValues := TValueCollection.Create(TTree(Self)); - Result := TValueCollection(FValues); -end; - -function TCustomAVLTreeMap.GetItem(const AKey: TKey): TValue; -var - LNode: PNode; -begin - LNode := Find(AKey); - if not Assigned(LNode) then - raise EAVLTree.CreateRes(@SDictionaryKeyDoesNotExist); - result := LNode.Value; -end; - -procedure TCustomAVLTreeMap.SetItem(const AKey: TKey; const AValue: TValue); -begin - Find(AKey).Value := AValue; -end; - -constructor TCustomAVLTreeMap.Create; -begin - FComparer := TComparer.Default; -end; - -constructor TCustomAVLTreeMap.Create(const AComparer: IComparer); -begin - FComparer := AComparer; -end; - -function TCustomAVLTreeMap.NewNode: PNode; -begin - Result := AllocMem(SizeOf(TNode)); - Initialize(Result^); -end; - -function TCustomAVLTreeMap.NewNodeArray(ACount: SizeInt): PNode; -begin - Result := AllocMem(ACount * SizeOf(TNode)); - Initialize(Result^, ACount); -end; - -procedure TCustomAVLTreeMap.NewNodeArray(out AArray: TArray; ACount: SizeInt); -var - i: Integer; -begin - SetLength(AArray, ACount); - for i := 0 to ACount-1 do - AArray[i] := NewNode; -end; - -procedure TCustomAVLTreeMap.DisposeNode(ANode: PNode); -begin - Dispose(ANode); -end; - -procedure TCustomAVLTreeMap.DisposeNodeArray(ANode: PNode; ACount: SizeInt); -begin - Finalize(ANode^, ACount); - FreeMem(ANode); -end; - -procedure TCustomAVLTreeMap.DisposeNodeArray(var AArray: TArray); -var - i: Integer; -begin - for i := 0 to High(AArray) do - Dispose(AArray[i]); - AArray := nil; -end; - -destructor TCustomAVLTreeMap.Destroy; -begin - FKeys.Free; - FValues.Free; - FNodes.Free; - Clear; -end; - -function TCustomAVLTreeMap.AddNode(ANode: PNode): boolean; -begin - Result := ANode=InternalAdd(ANode, false); -end; - -function TCustomAVLTreeMap.AddNodeArray(const AArray: TArray): boolean; -var - LNode: PNode; -begin - result := true; - for LNode in AArray do - result := result and AddNode(LNode); -end; - -function TCustomAVLTreeMap.Add(constref APair: TTreePair): PNode; -begin - Result := NewNode; - Result.Data.Key := APair.Key; - Result.Data.Value := APair.Value; - Result := InternalAdd(Result, true); -end; - -function TCustomAVLTreeMap.Add(constref AKey: TKey; constref AValue: TValue): PNode; -begin - Result := NewNode; - Result.Data.Key := AKey; - Result.Data.Value := AValue; - Result := InternalAdd(Result, true); -end; - -function TCustomAVLTreeMap.Remove(constref AKey: TKey; ADisposeNode: boolean): boolean; -var - LNode: PNode; -begin - LNode:=Find(AKey); - if LNode<>nil then begin - Delete(LNode, ADisposeNode); - Result:=true; - end else - Result:=false; -end; - -function TCustomAVLTreeMap.ExtractPair(constref AKey: TKey; ADisposeNode: boolean): TTreePair; -var - LNode: PNode; -begin - LNode:=Find(AKey); - if LNode<>nil then - begin - Result.Key := AKey; - Result.Value := DoRemove(LNode, cnExtracted, ADisposeNode); - end else - Result := Default(TTreePair); -end; - -function TCustomAVLTreeMap.ExtractPair(constref ANode: PNode; ADispose: boolean = true): TTreePair; -begin - Result.Key := ANode.Key; - Result.Value := DoRemove(ANode, cnExtracted, ADispose); -end; - -function TCustomAVLTreeMap.Extract(constref AKey: TKey; ADisposeNode: boolean): PNode; -begin - Result:=Find(AKey); - if Result<>nil then - begin - DoRemove(Result, cnExtracted, false); - if ADisposeNode then - Result := nil; - end; -end; - -function TCustomAVLTreeMap.ExtractNode(ANode: PNode; ADispose: boolean): PNode; -begin - DoRemove(ANode, cnExtracted, ADispose); - if ADispose then - Result := nil - else - Result := ANode; -end; - -function TCustomAVLTreeMap.ExtractNodeArray(const AArray: TArray; ADispose: boolean): TArray; -var - LNode: PNode; -begin - for LNode in AArray do - ExtractNode(LNode, ADispose); - if ADispose then - Result := nil - else - Result := AArray; -end; - -procedure TCustomAVLTreeMap.Delete(ANode: PNode; ADispose: boolean); -begin - DoRemove(ANode, cnRemoved, ADispose); -end; - -procedure TCustomAVLTreeMap.DeleteArray(const AArray: TArray; ADispose: boolean); -var - LNode: PNode; -begin - for LNode in AArray do - Delete(LNode, ADispose); -end; - -procedure TCustomAVLTreeMap.Clear(ADisposeNodes: Boolean); -begin - if (FRoot<>nil) and ADisposeNodes then - DisposeAllNodes(FRoot); - fRoot:=nil; - FCount:=0; -end; - -function TCustomAVLTreeMap.GetEnumerator: TPairEnumerator; -begin - Result := TPairEnumerator.Create(Self, true); -end; - -function TCustomAVLTreeMap.FindLowest: PNode; -begin - Result:=FRoot; - if Result<>nil then - while Result.Left<>nil do Result:=Result.Left; -end; - -function TCustomAVLTreeMap.FindHighest: PNode; -begin - Result:=FRoot; - if Result<>nil then - while Result.Right<>nil do Result:=Result.Right; -end; - -function TCustomAVLTreeMap.Find(constref AKey: TKey): PNode; -var - LComp: SizeInt; -begin - Result:=FRoot; - while (Result<>nil) do - begin - LComp:=Compare(AKey,Result.Key); - if LComp=0 then - Exit; - if LComp<0 then - Result:=Result.Left - else - Result:=Result.Right - end; -end; - -function TCustomAVLTreeMap.ContainsKey(constref AKey: TKey; out ANode: PNode): boolean; -begin - ANode := Find(AKey); - Result := Assigned(ANode); -end; - -function TCustomAVLTreeMap.ContainsKey(constref AKey: TKey): boolean; overload; inline; -begin - Result := Assigned(Find(AKey)); -end; - -procedure TCustomAVLTreeMap.ConsistencyCheck; -var - RealCount: SizeInt; -begin - RealCount:=0; - if FRoot<>nil then begin - FRoot.ConsistencyCheck(Self); - RealCount:=FRoot.GetCount; - end; - if Count<>RealCount then - raise EAVLTree.Create('Count<>RealCount'); -end; - -procedure TCustomAVLTreeMap.WriteTreeNode(AStream: TStream; ANode: PNode); -var - b: String; - IsLeft: boolean; - LParent: PNode; - WasLeft: Boolean; -begin - if ANode=nil then exit; - WriteTreeNode(AStream, ANode.Right); - LParent:=ANode; - WasLeft:=false; - b:=''; - while LParent<>nil do begin - if LParent.Parent=nil then begin - if LParent=ANode then - b:='--'+b - else - b:=' '+b; - break; - end; - IsLeft:=LParent.Parent.Left=LParent; - if LParent=ANode then begin - if IsLeft then - b:='\-' - else - b:='/-'; - end else begin - if WasLeft=IsLeft then - b:=' '+b - else - b:='| '+b; - end; - WasLeft:=IsLeft; - LParent:=LParent.Parent; - end; - b:=b+NodeToReportStr(ANode)+LineEnding; - WriteStr(AStream, b); - WriteTreeNode(AStream, ANode.Left); -end; - -procedure TCustomAVLTreeMap.WriteReportToStream(AStream: TStream); -begin - WriteStr(AStream, '-Start-of-AVL-Tree-------------------'+LineEnding); - WriteTreeNode(AStream, fRoot); - WriteStr(AStream, '-End-Of-AVL-Tree---------------------'+LineEnding); -end; - -function TCustomAVLTreeMap.NodeToReportStr(ANode: PNode): string; -begin - Result:=Format(' Self=%p Parent=%p Balance=%d', [ANode, ANode.Parent, ANode.Balance]); -end; - -function TCustomAVLTreeMap.ReportAsString: string; -var ms: TMemoryStream; -begin - Result:=''; - ms:=TMemoryStream.Create; - try - WriteReportToStream(ms); - ms.Position:=0; - SetLength(Result,ms.Size); - if Result<>'' then - ms.Read(Result[1],length(Result)); - finally - ms.Free; - end; -end; - -{ TIndexedAVLTreeMap } - -procedure TIndexedAVLTreeMap.RotateRightRight(ANode: PNode); -var - LOldRight: PNode; -begin - LOldRight:=ANode.Right; - inherited; - Inc(LOldRight.Data.Info, (1 + ANode.Data.Info)); -end; - -procedure TIndexedAVLTreeMap.RotateLeftLeft(ANode: PNode); -var - LOldLeft: PNode; -begin - LOldLeft:=ANode.Left; - inherited; - Dec(ANode.Data.Info, (1 + LOldLeft.Data.Info)); -end; - -procedure TIndexedAVLTreeMap.RotateRightLeft(ANode: PNode); -var - LB, LC: PNode; -begin - LB := ANode.Right; - LC := LB.Left; - inherited; - Dec(LB.Data.Info, 1+LC.Info); - Inc(LC.Data.Info, 1+ANode.Info); -end; - -procedure TIndexedAVLTreeMap.RotateLeftRight(ANode: PNode); -var - LB, LC: PNode; -begin - LB := ANode.Left; - LC := LB.Right; - inherited; - Inc(LC.Data.Info, 1+LB.Info); - Dec(ANode.Data.Info, 1+LC.Info); -end; - - -procedure TIndexedAVLTreeMap.NodeAdded(ANode: PNode); -var - LParent, LNode: PNode; -begin - FLastNode := nil; - LNode := ANode; - repeat - LParent:=LNode.Parent; - if (LParent=nil) then break; - if LParent.Left=LNode then - Inc(LParent.Data.Info); - LNode:=LParent; - until false; -end; - -procedure TIndexedAVLTreeMap.DeletingNode(ANode: PNode; AOrigin: boolean); -var - LParent: PNode; -begin - if not AOrigin then - Dec(ANode.Data.Info); - FLastNode := nil; - repeat - LParent:=ANode.Parent; - if (LParent=nil) then exit; - if LParent.Left=ANode then - Dec(LParent.Data.Info); - ANode:=LParent; - until false; -end; - -function TIndexedAVLTreeMap.GetNodeAtIndex(AIndex: SizeInt): PNode; -begin - if (AIndex<0) or (AIndex>=Count) then - raise EIndexedAVLTree.CreateFmt('TIndexedAVLTree: AIndex %d out of bounds 0..%d', [AIndex, Count]); - - if FLastNode<>nil then begin - if AIndex=FLastIndex then - Exit(FLastNode) - else if AIndex=FLastIndex+1 then begin - FLastIndex:=AIndex; - FLastNode:=FLastNode.Successor; - Exit(FLastNode); - end else if AIndex=FLastIndex-1 then begin - FLastIndex:=AIndex; - FLastNode:=FLastNode.Precessor; - Exit(FLastNode); - end; - end; - - FLastIndex:=AIndex; - Result:=FRoot; - repeat - if Result.Info>AIndex then - Result:=Result.Left - else if Result.Info=AIndex then begin - FLastNode:=Result; - Exit; - end - else begin - Dec(AIndex, Result.Info+1); - Result:=Result.Right; - end; - until false; -end; - -function TIndexedAVLTreeMap.NodeToIndex(ANode: PNode): SizeInt; -var - LNode: PNode; - LParent: PNode; -begin - if ANode=nil then - Exit(-1); - - if FLastNode=ANode then - Exit(FLastIndex); - - LNode:=ANode; - Result:=LNode.Info; - repeat - LParent:=LNode.Parent; - if LParent=nil then break; - if LParent.Right=LNode then - inc(Result,LParent.Info+1); - LNode:=LParent; - until false; - - FLastNode:=ANode; - FLastIndex:=Result; -end; - -procedure TIndexedAVLTreeMap.ConsistencyCheck; -var - LNode: PNode; - i: SizeInt; - LeftCount: SizeInt = 0; -begin - inherited ConsistencyCheck; - i:=0; - for LNode in Self.Nodes do - begin - if LNode.Left<>nil then - LeftCount:=LNode.Left.GetCount - else - LeftCount:=0; - - if LNode.Info<>LeftCount then - raise EIndexedAVLTree.CreateFmt('LNode.LeftCount=%d<>%d',[LNode.Info,LeftCount]); - - if GetNodeAtIndex(i)<>LNode then - raise EIndexedAVLTree.CreateFmt('GetNodeAtIndex(%d)<>%P',[i,LNode]); - FLastNode:=nil; - if GetNodeAtIndex(i)<>LNode then - raise EIndexedAVLTree.CreateFmt('GetNodeAtIndex(%d)<>%P',[i,LNode]); - - if NodeToIndex(LNode)<>i then - raise EIndexedAVLTree.CreateFmt('NodeToIndex(%P)<>%d',[LNode,i]); - FLastNode:=nil; - if NodeToIndex(LNode)<>i then - raise EIndexedAVLTree.CreateFmt('NodeToIndex(%P)<>%d',[LNode,i]); - - inc(i); - end; -end; - -function TIndexedAVLTreeMap.NodeToReportStr(ANode: PNode): string; -begin - Result:=Format(' Self=%p Parent=%p Balance=%d Idx=%d Info=%d', - [ANode,ANode.Parent, ANode.Balance, NodeToIndex(ANode), ANode.Info]); -end; - -{ TAVLTree } - -function TAVLTree.Add(constref AValue: T): PNode; -begin - Result := inherited Add(AValue, EmptyRecord); -end; - -function TAVLTree.AddNode(ANode: PNode): boolean; -begin - Result := inherited AddNode(ANode); -end; - -{ TIndexedAVLTree } - -function TIndexedAVLTree.Add(constref AValue: T): PNode; -begin - Result := inherited Add(AValue, EmptyRecord); -end; - -function TIndexedAVLTree.AddNode(ANode: PNode): boolean; -begin - Result := inherited AddNode(ANode); -end; - -{ TSortedSet.TSortedSetEnumerator } - -function TSortedSet.TSortedSetEnumerator.GetCurrent: T; -begin - Result := TTreeEnumerator(FEnumerator).GetCurrent; -end; - -constructor TSortedSet.TSortedSetEnumerator.Create(ASet: TCustomSet); -begin - TTreeEnumerator(FEnumerator) := TSortedSet(ASet).FInternalTree.Keys.DoGetEnumerator; -end; - -{ TSortedSet.TPointersEnumerator } - -function TSortedSet.TPointersEnumerator.DoMoveNext: boolean; -begin - Result := FEnumerator.MoveNext; -end; - -function TSortedSet.TPointersEnumerator.DoGetCurrent: PT; -begin - Result := FEnumerator.Current; -end; - -constructor TSortedSet.TPointersEnumerator.Create(ASortedSet: TSortedSet); -begin - FEnumerator := ASortedSet.FInternalTree.Keys.Ptr^.GetEnumerator; -end; - -{ TSortedSet } - -procedure TSortedSet.InternalAVLTreeNotify(ASender: TObject; constref AItem: T; AAction: TCollectionNotification); -begin - FOnNotify(Self, AItem, AAction); -end; - -function TSortedSet.GetPtrEnumerator: TEnumerator; -begin - Result := TPointersEnumerator.Create(Self); -end; - -function TSortedSet.GetCount: SizeInt; -begin - Result := FInternalTree.Count; -end; - -function TSortedSet.GetCapacity: SizeInt; -begin - Result := FInternalTree.Count; -end; - -procedure TSortedSet.SetCapacity(AValue: SizeInt); -begin -end; - -function TSortedSet.GetOnNotify: TCollectionNotifyEvent; -begin - Result := FInternalTree.OnKeyNotify; -end; - -procedure TSortedSet.SetOnNotify(AValue: TCollectionNotifyEvent); -begin - FOnNotify := AValue; - if Assigned(AValue) then - FInternalTree.OnKeyNotify := InternalAVLTreeNotify - else - FInternalTree.OnKeyNotify := nil; -end; - -function TSortedSet.GetEnumerator: TCustomSetEnumerator; -begin - Result := TSortedSetEnumerator.Create(Self); -end; - -constructor TSortedSet.Create; -begin - FInternalTree := TAVLTree.Create; -end; - -constructor TSortedSet.Create(const AComparer: IComparer); -begin - FInternalTree := TAVLTree.Create(AComparer); -end; - -destructor TSortedSet.Destroy; -begin - FInternalTree.Free; -end; - -function TSortedSet.Add(constref AValue: T): Boolean; -var - LNodePtr, LParent: TAVLTree.PNode; - LNode: TAVLTree.TNode; - LCompare: Integer; -begin - LNode.Data.Key := AValue; - - LCompare := FInternalTree.FindInsertNode(@LNode, LParent); - - Result := not((LCompare=0) and Assigned(LParent)); - if not Result then - Exit; - - LNodePtr := FInternalTree.NewNode; - LNodePtr^.Data.Key := AValue; - - case LCompare of - -1: LParent.Left := LNodePtr; - 1: LParent.Right := LNodePtr; - end; - - FInternalTree.InternalAdd(LNodePtr, LParent); - FInternalTree.NodeNotify(LNodePtr, cnAdded, false); -end; - -function TSortedSet.Remove(constref AValue: T): Boolean; -var - LNode: TAVLTree.PNode; -begin - LNode := FInternalTree.Find(AValue); - Result := Assigned(LNode); - if Result then - FInternalTree.Delete(LNode); -end; - -function TSortedSet.Extract(constref AValue: T): T; -var - LNode: TAVLTree.PNode; -begin - LNode := FInternalTree.Find(AValue); - if not Assigned(LNode) then - Exit(Default(T)); - - Result := FInternalTree.ExtractPair(LNode).Key; -end; - -procedure TSortedSet.Clear; -begin - FInternalTree.Clear; -end; - -function TSortedSet.Contains(constref AValue: T): Boolean; -begin - Result := FInternalTree.ContainsKey(AValue); -end; - -procedure TSortedSet.TrimExcess; -begin -end; - -{ TSortedHashSet.TSortedHashSetEqualityComparer } - -function TSortedHashSet.TSortedHashSetEqualityComparer.Equals(constref ALeft, ARight: PT): Boolean; -begin - if Assigned(FComparer) then - Result := FComparer.Compare(ALeft^, ARight^) = 0 - else - Result := FEqualityComparer.Equals(ALeft^, ARight^); -end; - -function TSortedHashSet.TSortedHashSetEqualityComparer.GetHashCode(constref AValue: PT): UInt32; -begin - Result := FEqualityComparer.GetHashCode(AValue^); -end; - -constructor TSortedHashSet.TSortedHashSetEqualityComparer.Create(const AComparer: IComparer); -begin - FComparer := AComparer; - FEqualityComparer := TEqualityComparer.Default; -end; - -constructor TSortedHashSet.TSortedHashSetEqualityComparer.Create(const AEqualityComparer: IEqualityComparer); -begin - FEqualityComparer := AEqualityComparer; -end; - -constructor TSortedHashSet.TSortedHashSetEqualityComparer.Create(const AComparer: IComparer; const AEqualityComparer: IEqualityComparer); -begin - FComparer := AComparer; - FEqualityComparer := AEqualityComparer; -end; - -{ TSortedHashSet.TSortedHashSetEnumerator } - -function TSortedHashSet.TSortedHashSetEnumerator.GetCurrent: T; -begin - Result := TTreeEnumerator(FEnumerator).Current; -end; - -constructor TSortedHashSet.TSortedHashSetEnumerator.Create(ASet: TCustomSet); -begin - FEnumerator := TSortedHashSet(ASet).FInternalTree.Keys.GetEnumerator; -end; - -{ TSortedHashSet.TPointersEnumerator } - -function TSortedHashSet.TPointersEnumerator.DoMoveNext: boolean; -begin - Result := FEnumerator.MoveNext; -end; - -function TSortedHashSet.TPointersEnumerator.DoGetCurrent: PT; -begin - Result := FEnumerator.Current; -end; - -constructor TSortedHashSet.TPointersEnumerator.Create(ASortedHashSet: TSortedHashSet); -begin - FEnumerator := ASortedHashSet.FInternalTree.Keys.Ptr^.GetEnumerator; -end; - -{ TSortedHashSet } - -procedure TSortedHashSet.InternalDictionaryNotify(ASender: TObject; constref AItem: PT; AAction: TCollectionNotification); -begin - FOnNotify(Self, AItem^, AAction); -end; - -function TSortedHashSet.GetPtrEnumerator: TEnumerator; -begin - Result := TPointersEnumerator.Create(Self); -end; - -function TSortedHashSet.DoGetEnumerator: TEnumerator; -begin - Result := GetEnumerator; -end; - -function TSortedHashSet.GetCount: SizeInt; -begin - Result := FInternalDictionary.Count; -end; - -function TSortedHashSet.GetCapacity: SizeInt; -begin - Result := FInternalDictionary.Capacity; -end; - -procedure TSortedHashSet.SetCapacity(AValue: SizeInt); -begin - FInternalDictionary.Capacity := AValue; -end; - -function TSortedHashSet.GetOnNotify: TCollectionNotifyEvent; -begin - Result := FInternalTree.OnKeyNotify; -end; - -procedure TSortedHashSet.SetOnNotify(AValue: TCollectionNotifyEvent); -begin - FOnNotify := AValue; - if Assigned(AValue) then - FInternalDictionary.OnKeyNotify := InternalDictionaryNotify - else - FInternalDictionary.OnKeyNotify := nil; -end; - -function TSortedHashSet.GetEnumerator: TCustomSetEnumerator; -begin - Result := TSortedHashSetEnumerator.Create(Self); -end; - -function TSortedHashSet.Add(constref AValue: T): Boolean; -var - LNode: TAVLTree.PNode; -begin - Result := not FInternalDictionary.ContainsKey(@AValue); - if Result then - begin - LNode := FInternalTree.Add(AValue); - FInternalDictionary.Add(@LNode.Data.Key, EmptyRecord); - end; -end; - -function TSortedHashSet.Remove(constref AValue: T): Boolean; -var - LIndex: SizeInt; -begin - LIndex := FInternalDictionary.FindBucketIndex(@AValue); - Result := LIndex >= 0; - if Result then - begin - FInternalDictionary.DoRemove(LIndex, cnRemoved); - FInternalTree.Remove(AValue); - end; -end; - -function TSortedHashSet.Extract(constref AValue: T): T; -var - LIndex: SizeInt; -begin - LIndex := FInternalDictionary.FindBucketIndex(@AValue); - if LIndex >= 0 then - begin - FInternalDictionary.DoRemove(LIndex, cnExtracted); - FInternalTree.Remove(AValue); - Result := AValue; - end else - Result := Default(T); -end; - -function TSortedHashSet.PeekPtr(constref AValue: T): PT; -var - LIndex: SizeInt; -begin - LIndex := FInternalDictionary.FindBucketIndex(@AValue); - if LIndex >= 0 then - result := FInternalDictionary.FItems[LIndex].Pair.Key - else - result := nil; -end; - -procedure TSortedHashSet.Clear; -begin - FInternalDictionary.Clear; - FInternalTree.Clear; -end; - -function TSortedHashSet.Contains(constref AValue: T): Boolean; -begin - Result := FInternalDictionary.ContainsKey(@AValue); -end; - -constructor TSortedHashSet.Create; -begin - FInternalTree := TAVLTree.Create; - FInternalDictionary := TOpenAddressingLP.Create(TSortedHashSetEqualityComparer.Create(TEqualityComparer.Default)); -end; - -constructor TSortedHashSet.Create(const AComparer: IEqualityComparer); -begin - Create(TComparer.Default, AComparer); -end; - -constructor TSortedHashSet.Create(const AComparer: IComparer); -begin - FInternalTree := TAVLTree.Create(AComparer); - FInternalDictionary := TOpenAddressingLP.Create(TSortedHashSetEqualityComparer.Create(AComparer)); -end; - -constructor TSortedHashSet.Create(const AComparer: IComparer; const AEqualityComparer: IEqualityComparer); -begin - FInternalTree := TAVLTree.Create(AComparer); - FInternalDictionary := TOpenAddressingLP.Create(TSortedHashSetEqualityComparer.Create(AComparer,AEqualityComparer)); -end; - -destructor TSortedHashSet.Destroy; -begin - FInternalDictionary.Free; - FInternalTree.Free; - inherited; -end; - -procedure TSortedHashSet.TrimExcess; -begin - FInternalDictionary.TrimExcess; -end; - -end. diff --git a/components/sparta/generics/source/sparta_generics.defaults.pas b/components/sparta/generics/source/sparta_generics.defaults.pas deleted file mode 100644 index 054fe76b79..0000000000 --- a/components/sparta/generics/source/sparta_generics.defaults.pas +++ /dev/null @@ -1,3357 +0,0 @@ -{ - This file is part of the Free Pascal/NewPascal run time library. - Copyright (c) 2014 by Maciej Izak (hnb) - member of the NewPascal development team (http://newpascal.org) - - Copyright(c) 2004-2018 DaThoX - - It contains the generics collections 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. - - Acknowledgment - - Thanks to Sphere 10 Software (http://sphere10.com) for sponsoring - many new types and major refactoring of entire library - - Thanks to mORMot (http://synopse.info) project for the best implementations - of hashing functions like crc32c and xxHash32 :) - - **********************************************************************} - -unit sparta_Generics.Defaults; - -{$MODE DELPHI}{$H+} -{$POINTERMATH ON} -{$MACRO ON} -{$COPERATORS ON} -{$HINTS OFF} -{$WARNINGS OFF} -{$NOTES OFF} -{$OVERFLOWCHECKS OFF} -{$RANGECHECKS OFF} - -interface - -uses - Classes, SysUtils, TypInfo, Variants, Math, - sparta_Generics.Hashes, sparta_Generics.Strings, sparta_Generics.Helpers; - -type - IComparer = interface - function Compare(constref Left, Right: T): Integer; overload; - end; - - TOnComparison = function(constref Left, Right: T): Integer of object; - TComparisonFunc = function(constref Left, Right: T): Integer; - - TComparer = class(TInterfacedObject, IComparer) - public - class function Default: IComparer; static; - function Compare(constref ALeft, ARight: T): Integer; virtual; abstract; overload; - - class function Construct(const AComparison: TOnComparison): IComparer; overload; - class function Construct(const AComparison: TComparisonFunc): IComparer; overload; - end; - - TDelegatedComparerEvents = class(TComparer) - private - FComparison: TOnComparison; - public - function Compare(constref ALeft, ARight: T): Integer; override; - constructor Create(AComparison: TOnComparison); - end; - - TDelegatedComparerFunc = class(TComparer) - private - FComparison: TComparisonFunc; - public - function Compare(constref ALeft, ARight: T): Integer; override; - constructor Create(AComparison: TComparisonFunc); - end; - - IEqualityComparer = interface - function Equals(constref ALeft, ARight: T): Boolean; - function GetHashCode(constref AValue: T): UInt32; - end; - - IExtendedEqualityComparer = interface(IEqualityComparer) - procedure GetHashList(constref AValue: T; AHashList: PUInt32); // for double hashing and more - end; - - ShortString1 = string[1]; - ShortString2 = string[2]; - ShortString3 = string[3]; - - { TAbstractInterface } - - TInterface = class - public - function QueryInterface(constref {%H-}IID: TGUID;{%H-} out Obj): HResult; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual; - function _AddRef: LongInt; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual; abstract; - function _Release: LongInt; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual; abstract; - end; - - { TRawInterface } - - TRawInterface = class(TInterface) - public - function _AddRef: LongInt; override; - function _Release: LongInt; override; - end; - - { TComTypeSizeInterface } - - // INTERNAL USE ONLY! - TComTypeSizeInterface = class(TInterface) - public - // warning ! self as PSpoofInterfacedTypeSizeObject - function _AddRef: LongInt; override; - // warning ! self as PSpoofInterfacedTypeSizeObject - function _Release: LongInt; override; - end; - - { TSingletonImplementation } - - TSingletonImplementation = class(TRawInterface, IInterface) - public - function QueryInterface(constref IID: TGUID; out Obj): HResult; override; - end; - - TCompare = class - protected - // warning ! self as PSpoofInterfacedTypeSizeObject - class function _Binary(constref ALeft, ARight): Integer; - // warning ! self as PSpoofInterfacedTypeSizeObject - class function _DynArray(constref ALeft, ARight: Pointer): Integer; - public - class function Integer(constref ALeft, ARight: Integer): Integer; - class function Int8(constref ALeft, ARight: Int8): Integer; - class function Int16(constref ALeft, ARight: Int16): Integer; - class function Int32(constref ALeft, ARight: Int32): Integer; - class function Int64(constref ALeft, ARight: Int64): Integer; - class function UInt8(constref ALeft, ARight: UInt8): Integer; - class function UInt16(constref ALeft, ARight: UInt16): Integer; - class function UInt32(constref ALeft, ARight: UInt32): Integer; - class function UInt64(constref ALeft, ARight: UInt64): Integer; - class function Single(constref ALeft, ARight: Single): Integer; - class function Double(constref ALeft, ARight: Double): Integer; - class function Extended(constref ALeft, ARight: Extended): Integer; - class function Currency(constref ALeft, ARight: Currency): Integer; - class function Comp(constref ALeft, ARight: Comp): Integer; - class function Binary(constref ALeft, ARight; const ASize: SizeInt): Integer; - class function DynArray(constref ALeft, ARight: Pointer; const AElementSize: SizeInt): Integer; - class function ShortString1(constref ALeft, ARight: ShortString1): Integer; - class function ShortString2(constref ALeft, ARight: ShortString2): Integer; - class function ShortString3(constref ALeft, ARight: ShortString3): Integer; - class function &String(constref ALeft, ARight: string): Integer; - class function ShortString(constref ALeft, ARight: ShortString): Integer; - class function AnsiString(constref ALeft, ARight: AnsiString): Integer; - class function WideString(constref ALeft, ARight: WideString): Integer; - class function UnicodeString(constref ALeft, ARight: UnicodeString): Integer; - class function Method(constref ALeft, ARight: TMethod): Integer; - class function Variant(constref ALeft, ARight: PVariant): Integer; - class function Pointer(constref ALeft, ARight: PtrUInt): Integer; - end; - - { TEquals } - - TEquals = class - protected - // warning ! self as PSpoofInterfacedTypeSizeObject - class function _Binary(constref ALeft, ARight): Boolean; - // warning ! self as PSpoofInterfacedTypeSizeObject - class function _DynArray(constref ALeft, ARight: Pointer): Boolean; - public - class function Integer(constref ALeft, ARight: Integer): Boolean; - class function Int8(constref ALeft, ARight: Int8): Boolean; - class function Int16(constref ALeft, ARight: Int16): Boolean; - class function Int32(constref ALeft, ARight: Int32): Boolean; - class function Int64(constref ALeft, ARight: Int64): Boolean; - class function UInt8(constref ALeft, ARight: UInt8): Boolean; - class function UInt16(constref ALeft, ARight: UInt16): Boolean; - class function UInt32(constref ALeft, ARight: UInt32): Boolean; - class function UInt64(constref ALeft, ARight: UInt64): Boolean; - class function Single(constref ALeft, ARight: Single): Boolean; - class function Double(constref ALeft, ARight: Double): Boolean; - class function Extended(constref ALeft, ARight: Extended): Boolean; - class function Currency(constref ALeft, ARight: Currency): Boolean; - class function Comp(constref ALeft, ARight: Comp): Boolean; - class function Binary(constref ALeft, ARight; const ASize: SizeInt): Boolean; - class function DynArray(constref ALeft, ARight: Pointer; const AElementSize: SizeInt): Boolean; - class function &Class(constref ALeft, ARight: TObject): Boolean; - class function ShortString1(constref ALeft, ARight: ShortString1): Boolean; - class function ShortString2(constref ALeft, ARight: ShortString2): Boolean; - class function ShortString3(constref ALeft, ARight: ShortString3): Boolean; - class function &String(constref ALeft, ARight: String): Boolean; - class function ShortString(constref ALeft, ARight: ShortString): Boolean; - class function AnsiString(constref ALeft, ARight: AnsiString): Boolean; - class function WideString(constref ALeft, ARight: WideString): Boolean; - class function UnicodeString(constref ALeft, ARight: UnicodeString): Boolean; - class function Method(constref ALeft, ARight: TMethod): Boolean; - class function Variant(constref ALeft, ARight: PVariant): Boolean; - class function Pointer(constref ALeft, ARight: PtrUInt): Boolean; - end; - - THashServiceClass = class of THashService; - TExtendedHashServiceClass = class of TExtendedHashService; - THashFactoryClass = class of THashFactory; - - TExtendedHashFactoryClass = class of TExtendedHashFactory; - - { TComparerService } - -{$DEFINE STD_RAW_INTERFACE_METHODS := - QueryInterface: @TRawInterface.QueryInterface; - _AddRef : @TRawInterface._AddRef; - _Release : @TRawInterface._Release -} - -{$DEFINE STD_COM_TYPESIZE_INTERFACE_METHODS := - QueryInterface: @TComTypeSizeInterface.QueryInterface; - _AddRef : @TComTypeSizeInterface._AddRef; - _Release : @TComTypeSizeInterface._Release -} - - TGetHashListOptions = set of (ghloHashListAsInitData); - - THashFactory = class - private type - PPEqualityComparerVMT = ^PEqualityComparerVMT; - PEqualityComparerVMT = ^TEqualityComparerVMT; - TEqualityComparerVMT = packed record - QueryInterface: CodePointer; - _AddRef: CodePointer; - _Release: CodePointer; - Equals: CodePointer; - GetHashCode: CodePointer; - __Reserved: CodePointer; // initially or TExtendedEqualityComparerVMT compatibility - // (important when ExtendedEqualityComparer is calling Binary method) - __ClassRef: THashFactoryClass; // hidden field in VMT. For class ref THashFactoryClass - end; - - private -(*********************************************************************************************************************** - Hashes -(**********************************************************************************************************************) - - class function Int8 (constref AValue: Int8 ): UInt32; overload; - class function Int16 (constref AValue: Int16 ): UInt32; overload; - class function Int32 (constref AValue: Int32 ): UInt32; overload; - class function Int64 (constref AValue: Int64 ): UInt32; overload; - class function UInt8 (constref AValue: UInt8 ): UInt32; overload; - class function UInt16 (constref AValue: UInt16 ): UInt32; overload; - class function UInt32 (constref AValue: UInt32 ): UInt32; overload; - class function UInt64 (constref AValue: UInt64 ): UInt32; overload; - class function Single (constref AValue: Single ): UInt32; overload; - class function Double (constref AValue: Double ): UInt32; overload; - class function Extended (constref AValue: Extended ): UInt32; overload; - class function Currency (constref AValue: Currency ): UInt32; overload; - class function Comp (constref AValue: Comp ): UInt32; overload; - // warning ! self as PSpoofInterfacedTypeSizeObject - class function Binary (constref AValue ): UInt32; overload; - // warning ! self as PSpoofInterfacedTypeSizeObject - class function DynArray (constref AValue: Pointer ): UInt32; overload; - class function &Class (constref AValue: TObject ): UInt32; overload; - class function ShortString1 (constref AValue: ShortString1 ): UInt32; overload; - class function ShortString2 (constref AValue: ShortString2 ): UInt32; overload; - class function ShortString3 (constref AValue: ShortString3 ): UInt32; overload; - class function ShortString (constref AValue: ShortString ): UInt32; overload; - class function AnsiString (constref AValue: AnsiString ): UInt32; overload; - class function WideString (constref AValue: WideString ): UInt32; overload; - class function UnicodeString(constref AValue: UnicodeString): UInt32; overload; - class function Method (constref AValue: TMethod ): UInt32; overload; - class function Variant (constref AValue: PVariant ): UInt32; overload; - class function Pointer (constref AValue: Pointer ): UInt32; overload; - public - const MAX_HASHLIST_COUNT = 1; - const HASH_FUNCTIONS_COUNT = 1; - const HASHLIST_COUNT_PER_FUNCTION: array[1..HASH_FUNCTIONS_COUNT] of Integer = (1); - const HASH_FUNCTIONS_MASK_SIZE = 1; - - class function GetHashService: THashServiceClass; virtual; abstract; - class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; virtual; abstract; reintroduce; - end; - - TExtendedHashFactory = class(THashFactory) - private type - PPExtendedEqualityComparerVMT = ^PExtendedEqualityComparerVMT; - PExtendedEqualityComparerVMT = ^TExtendedEqualityComparerVMT; - TExtendedEqualityComparerVMT = packed record - QueryInterface: CodePointer; - _AddRef: CodePointer; - _Release: CodePointer; - Equals: CodePointer; - GetHashCode: CodePointer; - GetHashList: CodePointer; - __ClassRef: TExtendedHashFactoryClass; // hidden field in VMT. For class ref THashFactoryClass - end; - private -(*********************************************************************************************************************** - Hashes 2 -(**********************************************************************************************************************) - - class procedure Int8 (constref AValue: Int8 ; AHashList: PUInt32); overload; - class procedure Int16 (constref AValue: Int16 ; AHashList: PUInt32); overload; - class procedure Int32 (constref AValue: Int32 ; AHashList: PUInt32); overload; - class procedure Int64 (constref AValue: Int64 ; AHashList: PUInt32); overload; - class procedure UInt8 (constref AValue: UInt8 ; AHashList: PUInt32); overload; - class procedure UInt16 (constref AValue: UInt16 ; AHashList: PUInt32); overload; - class procedure UInt32 (constref AValue: UInt32 ; AHashList: PUInt32); overload; - class procedure UInt64 (constref AValue: UInt64 ; AHashList: PUInt32); overload; - class procedure Single (constref AValue: Single ; AHashList: PUInt32); overload; - class procedure Double (constref AValue: Double ; AHashList: PUInt32); overload; - class procedure Extended (constref AValue: Extended ; AHashList: PUInt32); overload; - class procedure Currency (constref AValue: Currency ; AHashList: PUInt32); overload; - class procedure Comp (constref AValue: Comp ; AHashList: PUInt32); overload; - // warning ! self as PSpoofInterfacedTypeSizeObject - class procedure Binary (constref AValue ; AHashList: PUInt32); overload; - // warning ! self as PSpoofInterfacedTypeSizeObject - class procedure DynArray (constref AValue: Pointer ; AHashList: PUInt32); overload; - class procedure &Class (constref AValue: TObject ; AHashList: PUInt32); overload; - class procedure ShortString1 (constref AValue: ShortString1 ; AHashList: PUInt32); overload; - class procedure ShortString2 (constref AValue: ShortString2 ; AHashList: PUInt32); overload; - class procedure ShortString3 (constref AValue: ShortString3 ; AHashList: PUInt32); overload; - class procedure ShortString (constref AValue: ShortString ; AHashList: PUInt32); overload; - class procedure AnsiString (constref AValue: AnsiString ; AHashList: PUInt32); overload; - class procedure WideString (constref AValue: WideString ; AHashList: PUInt32); overload; - class procedure UnicodeString(constref AValue: UnicodeString; AHashList: PUInt32); overload; - class procedure Method (constref AValue: TMethod ; AHashList: PUInt32); overload; - class procedure Variant (constref AValue: PVariant ; AHashList: PUInt32); overload; - class procedure Pointer (constref AValue: Pointer ; AHashList: PUInt32); overload; - public - class procedure GetHashList(AKey: Pointer; ASize: SizeInt; AHashList: PUInt32; AOptions: TGetHashListOptions = []); virtual; abstract; - end; - - TComparerService = class abstract - private type - TSelectMethod = function(ATypeData: PTypeData; ASize: SizeInt): Pointer of object; - private - class function SelectIntegerEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; virtual; abstract; - class function SelectFloatEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; virtual; abstract; - class function SelectShortStringEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; virtual; abstract; - class function SelectBinaryEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; virtual; abstract; - class function SelectDynArrayEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; virtual; abstract; - private type - PSpoofInterfacedTypeSizeObject = ^TSpoofInterfacedTypeSizeObject; - TSpoofInterfacedTypeSizeObject = record - VMT: Pointer; - RefCount: LongInt; - Size: SizeInt; - end; - - PInstance = ^TInstance; - TInstance = record - class function Create(ASelector: Boolean; AInstance: Pointer): TComparerService.TInstance; static; - class function CreateSelector(ASelectorInstance: CodePointer): TComparerService.TInstance; static; - - case Selector: Boolean of - false: (Instance: Pointer); - true: (SelectorInstance: CodePointer); - end; - - PComparerVMT = ^TComparerVMT; - TComparerVMT = packed record - QueryInterface: CodePointer; - _AddRef: CodePointer; - _Release: CodePointer; - Compare: CodePointer; - end; - - TSelectFunc = function(ATypeData: PTypeData; ASize: SizeInt): Pointer; - - private - class function CreateInterface(AVMT: Pointer; ASize: SizeInt): PSpoofInterfacedTypeSizeObject; static; - - class function SelectIntegerComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; static; - class function SelectInt64Comparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; static; - class function SelectFloatComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; static; - class function SelectShortStringComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; static; - class function SelectBinaryComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; static; - class function SelectDynArrayComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; static; - private const - // IComparer VMT - Comparer_Int8_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Int8); - Comparer_Int16_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Int16 ); - Comparer_Int32_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Int32 ); - Comparer_Int64_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Int64 ); - Comparer_UInt8_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.UInt8 ); - Comparer_UInt16_VMT: TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.UInt16); - Comparer_UInt32_VMT: TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.UInt32); - Comparer_UInt64_VMT: TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.UInt64); - - Comparer_Single_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Single ); - Comparer_Double_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Double ); - Comparer_Extended_VMT: TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Extended); - - Comparer_Currency_VMT: TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Currency); - Comparer_Comp_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Comp ); - - Comparer_Binary_VMT : TComparerVMT = (STD_COM_TYPESIZE_INTERFACE_METHODS; Compare: @TCompare._Binary ); - Comparer_DynArray_VMT: TComparerVMT = (STD_COM_TYPESIZE_INTERFACE_METHODS; Compare: @TCompare._DynArray); - - Comparer_ShortString1_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.ShortString1 ); - Comparer_ShortString2_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.ShortString2 ); - Comparer_ShortString3_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.ShortString3 ); - Comparer_ShortString_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.ShortString ); - Comparer_AnsiString_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.AnsiString ); - Comparer_WideString_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.WideString ); - Comparer_UnicodeString_VMT: TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.UnicodeString); - - Comparer_Method_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Method ); - Comparer_Variant_VMT: TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Variant); - Comparer_Pointer_VMT: TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Pointer); - - // Instances - Comparer_Int8_Instance : Pointer = @Comparer_Int8_VMT ; - Comparer_Int16_Instance : Pointer = @Comparer_Int16_VMT ; - Comparer_Int32_Instance : Pointer = @Comparer_Int32_VMT ; - Comparer_Int64_Instance : Pointer = @Comparer_Int64_VMT ; - Comparer_UInt8_Instance : Pointer = @Comparer_UInt8_VMT ; - Comparer_UInt16_Instance: Pointer = @Comparer_UInt16_VMT; - Comparer_UInt32_Instance: Pointer = @Comparer_UInt32_VMT; - Comparer_UInt64_Instance: Pointer = @Comparer_UInt64_VMT; - - Comparer_Single_Instance : Pointer = @Comparer_Single_VMT ; - Comparer_Double_Instance : Pointer = @Comparer_Double_VMT ; - Comparer_Extended_Instance: Pointer = @Comparer_Extended_VMT; - - Comparer_Currency_Instance: Pointer = @Comparer_Currency_VMT; - Comparer_Comp_Instance : Pointer = @Comparer_Comp_VMT ; - - //Comparer_Binary_Instance : Pointer = @Comparer_Binary_VMT ; // dynamic instance - //Comparer_DynArray_Instance: Pointer = @Comparer_DynArray_VMT; // dynamic instance - - Comparer_ShortString1_Instance : Pointer = @Comparer_ShortString1_VMT ; - Comparer_ShortString2_Instance : Pointer = @Comparer_ShortString2_VMT ; - Comparer_ShortString3_Instance : Pointer = @Comparer_ShortString3_VMT ; - Comparer_ShortString_Instance : Pointer = @Comparer_ShortString_VMT ; - Comparer_AnsiString_Instance : Pointer = @Comparer_AnsiString_VMT ; - Comparer_WideString_Instance : Pointer = @Comparer_WideString_VMT ; - Comparer_UnicodeString_Instance: Pointer = @Comparer_UnicodeString_VMT; - - Comparer_Method_Instance : Pointer = @Comparer_Method_VMT ; - Comparer_Variant_Instance: Pointer = @Comparer_Variant_VMT; - Comparer_Pointer_Instance: Pointer = @Comparer_Pointer_VMT; - - ComparerInstances: array[TTypeKind] of TInstance = - ( - // tkUnknown - (Selector: True; SelectorInstance: @TComparerService.SelectBinaryComparer), - // tkInteger - (Selector: True; SelectorInstance: @TComparerService.SelectIntegerComparer), - // tkChar - (Selector: False; Instance: @Comparer_UInt8_Instance), - // tkEnumeration - (Selector: True; SelectorInstance: @TComparerService.SelectIntegerComparer), - // tkFloat - (Selector: True; SelectorInstance: @TComparerService.SelectFloatComparer), - // tkSet - (Selector: True; SelectorInstance: @TComparerService.SelectBinaryComparer), - // tkMethod - (Selector: False; Instance: @Comparer_Method_Instance), - // tkSString - (Selector: True; SelectorInstance: @TComparerService.SelectShortStringComparer), - // tkLString - only internal use / deprecated in compiler - (Selector: False; Instance: @Comparer_AnsiString_Instance), // <- unsure - // tkAString - (Selector: False; Instance: @Comparer_AnsiString_Instance), - // tkWString - (Selector: False; Instance: @Comparer_WideString_Instance), - // tkVariant - (Selector: False; Instance: @Comparer_Variant_Instance), - // tkArray - (Selector: True; SelectorInstance: @TComparerService.SelectBinaryComparer), - // tkRecord - (Selector: True; SelectorInstance: @TComparerService.SelectBinaryComparer), - // tkInterface - (Selector: False; Instance: @Comparer_Pointer_Instance), - // tkClass - (Selector: False; Instance: @Comparer_Pointer_Instance), - // tkObject - (Selector: True; SelectorInstance: @TComparerService.SelectBinaryComparer), - // tkWChar - (Selector: False; Instance: @Comparer_UInt16_Instance), - // tkBool - (Selector: True; SelectorInstance: @TComparerService.SelectIntegerComparer), - // tkInt64 - (Selector: False; Instance: @Comparer_Int64_Instance), - // tkQWord - (Selector: False; Instance: @Comparer_UInt64_Instance), - // tkDynArray - (Selector: True; SelectorInstance: @TComparerService.SelectDynArrayComparer), - // tkInterfaceRaw - (Selector: False; Instance: @Comparer_Pointer_Instance), - // tkProcVar - (Selector: False; Instance: @Comparer_Pointer_Instance), - // tkUString - (Selector: False; Instance: @Comparer_UnicodeString_Instance), - // tkUChar - WTF? ... http://bugs.freepascal.org/view.php?id=24609 - (Selector: False; Instance: @Comparer_UInt16_Instance), // <- unsure maybe Comparer_UInt32_Instance - // tkHelper - (Selector: False; Instance: @Comparer_Pointer_Instance), - // tkFile - (Selector: True; SelectorInstance: @TComparerService.SelectBinaryComparer), // <- unsure what type? - // tkClassRef - (Selector: False; Instance: @Comparer_Pointer_Instance), - // tkPointer - (Selector: False; Instance: @Comparer_Pointer_Instance) - ); - public - class function LookupComparer(ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; static; - end; - - THashService = class(TComparerService) - public - class function LookupEqualityComparer(ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; virtual; abstract; - end; - - TExtendedHashService = class(THashService) - public - class function LookupEqualityComparer(ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; override; - class function LookupExtendedEqualityComparer(ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; virtual; abstract; - end; - -{$DEFINE HASH_FACTORY := PPEqualityComparerVMT(Self)^.__ClassRef} -{$DEFINE EXTENDED_HASH_FACTORY := PPExtendedEqualityComparerVMT(Self)^.__ClassRef} - - { THashService } - - THashService = class(THashService) - private - class function SelectIntegerEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; - class function SelectFloatEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; - class function SelectShortStringEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; - class function SelectBinaryEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; - class function SelectDynArrayEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; - private const - // IEqualityComparer VMT templates -{$WARNINGS OFF} - EqualityComparer_Int8_VMT : THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Int8 ; GetHashCode: @THashFactory.Int8 ); - EqualityComparer_Int16_VMT : THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Int16 ; GetHashCode: @THashFactory.Int16 ); - EqualityComparer_Int32_VMT : THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Int32 ; GetHashCode: @THashFactory.Int32 ); - EqualityComparer_Int64_VMT : THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Int64 ; GetHashCode: @THashFactory.Int64 ); - EqualityComparer_UInt8_VMT : THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UInt8 ; GetHashCode: @THashFactory.UInt8 ); - EqualityComparer_UInt16_VMT: THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UInt16; GetHashCode: @THashFactory.UInt16); - EqualityComparer_UInt32_VMT: THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UInt32; GetHashCode: @THashFactory.UInt32); - EqualityComparer_UInt64_VMT: THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UInt64; GetHashCode: @THashFactory.UInt64); - - EqualityComparer_Single_VMT : THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Single ; GetHashCode: @THashFactory.Single ); - EqualityComparer_Double_VMT : THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Double ; GetHashCode: @THashFactory.Double ); - EqualityComparer_Extended_VMT: THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Extended; GetHashCode: @THashFactory.Extended); - - EqualityComparer_Currency_VMT: THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Currency; GetHashCode: @THashFactory.Currency); - EqualityComparer_Comp_VMT : THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Comp ; GetHashCode: @THashFactory.Comp ); - - EqualityComparer_Binary_VMT : THashFactory.TEqualityComparerVMT = (STD_COM_TYPESIZE_INTERFACE_METHODS; Equals: @TEquals._Binary ; GetHashCode: @THashFactory.Binary ); - EqualityComparer_DynArray_VMT: THashFactory.TEqualityComparerVMT = (STD_COM_TYPESIZE_INTERFACE_METHODS; Equals: @TEquals._DynArray; GetHashCode: @THashFactory.DynArray); - - EqualityComparer_Class_VMT: THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.&Class; GetHashCode: @THashFactory.&Class); - - EqualityComparer_ShortString1_VMT : THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.ShortString1 ; GetHashCode: @THashFactory.ShortString1 ); - EqualityComparer_ShortString2_VMT : THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.ShortString2 ; GetHashCode: @THashFactory.ShortString2 ); - EqualityComparer_ShortString3_VMT : THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.ShortString3 ; GetHashCode: @THashFactory.ShortString3 ); - EqualityComparer_ShortString_VMT : THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.ShortString ; GetHashCode: @THashFactory.ShortString ); - EqualityComparer_AnsiString_VMT : THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.AnsiString ; GetHashCode: @THashFactory.AnsiString ); - EqualityComparer_WideString_VMT : THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.WideString ; GetHashCode: @THashFactory.WideString ); - EqualityComparer_UnicodeString_VMT: THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UnicodeString; GetHashCode: @THashFactory.UnicodeString); - - EqualityComparer_Method_VMT : THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Method ; GetHashCode: @THashFactory.Method ); - EqualityComparer_Variant_VMT: THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Variant; GetHashCode: @THashFactory.Variant); - EqualityComparer_Pointer_VMT: THashFactory.TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Pointer; GetHashCode: @THashFactory.Pointer); -{.$WARNINGS ON} // do not enable warnings ever in this unit, or you will get many warnings about uninitialized TEqualityComparerVMT fields - private class var - // IEqualityComparer VMT - FEqualityComparer_Int8_VMT : THashFactory.TEqualityComparerVMT; - FEqualityComparer_Int16_VMT : THashFactory.TEqualityComparerVMT; - FEqualityComparer_Int32_VMT : THashFactory.TEqualityComparerVMT; - FEqualityComparer_Int64_VMT : THashFactory.TEqualityComparerVMT; - FEqualityComparer_UInt8_VMT : THashFactory.TEqualityComparerVMT; - FEqualityComparer_UInt16_VMT: THashFactory.TEqualityComparerVMT; - FEqualityComparer_UInt32_VMT: THashFactory.TEqualityComparerVMT; - FEqualityComparer_UInt64_VMT: THashFactory.TEqualityComparerVMT; - - FEqualityComparer_Single_VMT : THashFactory.TEqualityComparerVMT; - FEqualityComparer_Double_VMT : THashFactory.TEqualityComparerVMT; - FEqualityComparer_Extended_VMT: THashFactory.TEqualityComparerVMT; - - FEqualityComparer_Currency_VMT: THashFactory.TEqualityComparerVMT; - FEqualityComparer_Comp_VMT : THashFactory.TEqualityComparerVMT; - - FEqualityComparer_Binary_VMT : THashFactory.TEqualityComparerVMT; - FEqualityComparer_DynArray_VMT: THashFactory.TEqualityComparerVMT; - - FEqualityComparer_Class_VMT: THashFactory.TEqualityComparerVMT; - - FEqualityComparer_ShortString1_VMT : THashFactory.TEqualityComparerVMT; - FEqualityComparer_ShortString2_VMT : THashFactory.TEqualityComparerVMT; - FEqualityComparer_ShortString3_VMT : THashFactory.TEqualityComparerVMT; - FEqualityComparer_ShortString_VMT : THashFactory.TEqualityComparerVMT; - FEqualityComparer_AnsiString_VMT : THashFactory.TEqualityComparerVMT; - FEqualityComparer_WideString_VMT : THashFactory.TEqualityComparerVMT; - FEqualityComparer_UnicodeString_VMT: THashFactory.TEqualityComparerVMT; - - FEqualityComparer_Method_VMT : THashFactory.TEqualityComparerVMT; - FEqualityComparer_Variant_VMT: THashFactory.TEqualityComparerVMT; - FEqualityComparer_Pointer_VMT: THashFactory.TEqualityComparerVMT; - - FEqualityComparer_Int8_Instance : Pointer; - FEqualityComparer_Int16_Instance : Pointer; - FEqualityComparer_Int32_Instance : Pointer; - FEqualityComparer_Int64_Instance : Pointer; - FEqualityComparer_UInt8_Instance : Pointer; - FEqualityComparer_UInt16_Instance : Pointer; - FEqualityComparer_UInt32_Instance : Pointer; - FEqualityComparer_UInt64_Instance : Pointer; - - FEqualityComparer_Single_Instance : Pointer; - FEqualityComparer_Double_Instance : Pointer; - FEqualityComparer_Extended_Instance : Pointer; - - FEqualityComparer_Currency_Instance : Pointer; - FEqualityComparer_Comp_Instance : Pointer; - - //FEqualityComparer_Binary_Instance : Pointer; // dynamic instance - //FEqualityComparer_DynArray_Instance : Pointer; // dynamic instance - - FEqualityComparer_ShortString1_Instance : Pointer; - FEqualityComparer_ShortString2_Instance : Pointer; - FEqualityComparer_ShortString3_Instance : Pointer; - FEqualityComparer_ShortString_Instance : Pointer; - FEqualityComparer_AnsiString_Instance : Pointer; - FEqualityComparer_WideString_Instance : Pointer; - FEqualityComparer_UnicodeString_Instance: Pointer; - - FEqualityComparer_Method_Instance : Pointer; - FEqualityComparer_Variant_Instance : Pointer; - FEqualityComparer_Pointer_Instance : Pointer; - - - FEqualityComparerInstances: array[TTypeKind] of TInstance; - private - class constructor Create; - public - class function LookupEqualityComparer(ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; override; - end; - - { TExtendedHashService } - - TExtendedHashService = class(TExtendedHashService) - private - class function SelectIntegerEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; - class function SelectFloatEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; - class function SelectShortStringEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; - class function SelectBinaryEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; - class function SelectDynArrayEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; - private const - // IExtendedEqualityComparer VMT templates -{$WARNINGS OFF} - ExtendedEqualityComparer_Int8_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Int8 ; GetHashCode: @THashFactory.Int8 ; GetHashList: @TExtendedHashFactory.Int8 ); - ExtendedEqualityComparer_Int16_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Int16 ; GetHashCode: @THashFactory.Int16 ; GetHashList: @TExtendedHashFactory.Int16 ); - ExtendedEqualityComparer_Int32_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Int32 ; GetHashCode: @THashFactory.Int32 ; GetHashList: @TExtendedHashFactory.Int32 ); - ExtendedEqualityComparer_Int64_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Int64 ; GetHashCode: @THashFactory.Int64 ; GetHashList: @TExtendedHashFactory.Int64 ); - ExtendedEqualityComparer_UInt8_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UInt8 ; GetHashCode: @THashFactory.UInt8 ; GetHashList: @TExtendedHashFactory.UInt8 ); - ExtendedEqualityComparer_UInt16_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UInt16; GetHashCode: @THashFactory.UInt16; GetHashList: @TExtendedHashFactory.UInt16); - ExtendedEqualityComparer_UInt32_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UInt32; GetHashCode: @THashFactory.UInt32; GetHashList: @TExtendedHashFactory.UInt32); - ExtendedEqualityComparer_UInt64_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UInt64; GetHashCode: @THashFactory.UInt64; GetHashList: @TExtendedHashFactory.UInt64); - - ExtendedEqualityComparer_Single_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Single ; GetHashCode: @THashFactory.Single ; GetHashList: @TExtendedHashFactory.Single ); - ExtendedEqualityComparer_Double_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Double ; GetHashCode: @THashFactory.Double ; GetHashList: @TExtendedHashFactory.Double ); - ExtendedEqualityComparer_Extended_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Extended; GetHashCode: @THashFactory.Extended; GetHashList: @TExtendedHashFactory.Extended); - - ExtendedEqualityComparer_Currency_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Currency; GetHashCode: @THashFactory.Currency; GetHashList: @TExtendedHashFactory.Currency); - ExtendedEqualityComparer_Comp_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Comp ; GetHashCode: @THashFactory.Comp ; GetHashList: @TExtendedHashFactory.Comp ); - - ExtendedEqualityComparer_Binary_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_COM_TYPESIZE_INTERFACE_METHODS; Equals: @TEquals._Binary ; GetHashCode: @THashFactory.Binary ; GetHashList: @TExtendedHashFactory.Binary ); - ExtendedEqualityComparer_DynArray_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_COM_TYPESIZE_INTERFACE_METHODS; Equals: @TEquals._DynArray; GetHashCode: @THashFactory.DynArray; GetHashList: @TExtendedHashFactory.DynArray); - - ExtendedEqualityComparer_Class_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.&Class; GetHashCode: @THashFactory.&Class; GetHashList: @TExtendedHashFactory.&Class); - - ExtendedEqualityComparer_ShortString1_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.ShortString1 ; GetHashCode: @THashFactory.ShortString1 ; GetHashList: @TExtendedHashFactory.ShortString1 ); - ExtendedEqualityComparer_ShortString2_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.ShortString2 ; GetHashCode: @THashFactory.ShortString2 ; GetHashList: @TExtendedHashFactory.ShortString2 ); - ExtendedEqualityComparer_ShortString3_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.ShortString3 ; GetHashCode: @THashFactory.ShortString3 ; GetHashList: @TExtendedHashFactory.ShortString3 ); - ExtendedEqualityComparer_ShortString_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.ShortString ; GetHashCode: @THashFactory.ShortString ; GetHashList: @TExtendedHashFactory.ShortString ); - ExtendedEqualityComparer_AnsiString_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.AnsiString ; GetHashCode: @THashFactory.AnsiString ; GetHashList: @TExtendedHashFactory.AnsiString ); - ExtendedEqualityComparer_WideString_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.WideString ; GetHashCode: @THashFactory.WideString ; GetHashList: @TExtendedHashFactory.WideString ); - ExtendedEqualityComparer_UnicodeString_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UnicodeString; GetHashCode: @THashFactory.UnicodeString; GetHashList: @TExtendedHashFactory.UnicodeString); - - ExtendedEqualityComparer_Method_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Method ; GetHashCode: @THashFactory.Method ; GetHashList: @TExtendedHashFactory.Method ); - ExtendedEqualityComparer_Variant_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Variant; GetHashCode: @THashFactory.Variant; GetHashList: @TExtendedHashFactory.Variant); - ExtendedEqualityComparer_Pointer_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Pointer; GetHashCode: @THashFactory.Pointer; GetHashList: @TExtendedHashFactory.Pointer); -{.$WARNINGS ON} // do not enable warnings ever in this unit, or you will get many warnings about uninitialized TEqualityComparerVMT fields - private class var - // IExtendedEqualityComparer VMT - FExtendedEqualityComparer_Int8_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_Int16_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_Int32_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_Int64_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_UInt8_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_UInt16_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_UInt32_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_UInt64_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT; - - FExtendedEqualityComparer_Single_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_Double_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_Extended_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT; - - FExtendedEqualityComparer_Currency_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_Comp_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT; - - FExtendedEqualityComparer_Binary_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_DynArray_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT; - - FExtendedEqualityComparer_Class_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT; - - FExtendedEqualityComparer_ShortString1_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_ShortString2_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_ShortString3_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_ShortString_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_AnsiString_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_WideString_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_UnicodeString_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT; - - FExtendedEqualityComparer_Method_VMT : TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_Variant_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT; - FExtendedEqualityComparer_Pointer_VMT: TExtendedHashFactory.TExtendedEqualityComparerVMT; - - FExtendedEqualityComparer_Int8_Instance : Pointer; - FExtendedEqualityComparer_Int16_Instance : Pointer; - FExtendedEqualityComparer_Int32_Instance : Pointer; - FExtendedEqualityComparer_Int64_Instance : Pointer; - FExtendedEqualityComparer_UInt8_Instance : Pointer; - FExtendedEqualityComparer_UInt16_Instance : Pointer; - FExtendedEqualityComparer_UInt32_Instance : Pointer; - FExtendedEqualityComparer_UInt64_Instance : Pointer; - - FExtendedEqualityComparer_Single_Instance : Pointer; - FExtendedEqualityComparer_Double_Instance : Pointer; - FExtendedEqualityComparer_Extended_Instance : Pointer; - - FExtendedEqualityComparer_Currency_Instance : Pointer; - FExtendedEqualityComparer_Comp_Instance : Pointer; - - //FExtendedEqualityComparer_Binary_Instance : Pointer; // dynamic instance - //FExtendedEqualityComparer_DynArray_Instance : Pointer; // dynamic instance - - FExtendedEqualityComparer_ShortString1_Instance : Pointer; - FExtendedEqualityComparer_ShortString2_Instance : Pointer; - FExtendedEqualityComparer_ShortString3_Instance : Pointer; - FExtendedEqualityComparer_ShortString_Instance : Pointer; - FExtendedEqualityComparer_AnsiString_Instance : Pointer; - FExtendedEqualityComparer_WideString_Instance : Pointer; - FExtendedEqualityComparer_UnicodeString_Instance: Pointer; - - FExtendedEqualityComparer_Method_Instance : Pointer; - FExtendedEqualityComparer_Variant_Instance : Pointer; - FExtendedEqualityComparer_Pointer_Instance : Pointer; - - // all instances - FExtendedEqualityComparerInstances: array[TTypeKind] of TInstance; - private - class constructor Create; - public - class function LookupExtendedEqualityComparer(ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; override; - end; - - TOnEqualityComparison = function(constref ALeft, ARight: T): Boolean of object; - TEqualityComparisonFunc = function(constref ALeft, ARight: T): Boolean; - - TOnHasher = function(constref AValue: T): UInt32 of object; - TOnExtendedHasher = procedure(constref AValue: T; AHashList: PUInt32) of object; - THasherFunc = function(constref AValue: T): UInt32; - TExtendedHasherFunc = procedure(constref AValue: T; AHashList: PUInt32); - - TEqualityComparer = class(TInterfacedObject, IEqualityComparer) - public - class function Default: IEqualityComparer; static; overload; - class function Default(AHashFactoryClass: THashFactoryClass): IEqualityComparer; static; overload; - - class function Construct(const AEqualityComparison: TOnEqualityComparison; - const AHasher: TOnHasher): IEqualityComparer; overload; - class function Construct(const AEqualityComparison: TEqualityComparisonFunc; - const AHasher: THasherFunc): IEqualityComparer; overload; - - function Equals(constref ALeft, ARight: T): Boolean; virtual; overload; abstract; - function GetHashCode(constref AValue: T): UInt32; virtual; overload; abstract; - end; - - { TDelegatedEqualityComparerEvent } - - TDelegatedEqualityComparerEvents = class(TEqualityComparer) - private - FEqualityComparison: TOnEqualityComparison; - FHasher: TOnHasher; - public - function Equals(constref ALeft, ARight: T): Boolean; override; - function GetHashCode(constref AValue: T): UInt32; override; - - constructor Create(const AEqualityComparison: TOnEqualityComparison; - const AHasher: TOnHasher); - end; - - TDelegatedEqualityComparerFunc = class(TEqualityComparer) - private - FEqualityComparison: TEqualityComparisonFunc; - FHasher: THasherFunc; - public - function Equals(constref ALeft, ARight: T): Boolean; override; - function GetHashCode(constref AValue: T): UInt32; override; - - constructor Create(const AEqualityComparison: TEqualityComparisonFunc; - const AHasher: THasherFunc); - end; - - { TExtendedEqualityComparer } - - TExtendedEqualityComparer = class(TEqualityComparer, IExtendedEqualityComparer) - public - class function Default: IExtendedEqualityComparer; static; overload; reintroduce; - class function Default(AExtenedHashFactoryClass: TExtendedHashFactoryClass): IExtendedEqualityComparer; static; overload; reintroduce; - - class function Construct(const AEqualityComparison: TOnEqualityComparison; - const AHasher: TOnHasher; const AExtendedHasher: TOnExtendedHasher): IExtendedEqualityComparer; overload; reintroduce; - class function Construct(const AEqualityComparison: TEqualityComparisonFunc; - const AHasher: THasherFunc; const AExtendedHasher: TExtendedHasherFunc): IExtendedEqualityComparer; overload; reintroduce; - class function Construct(const AEqualityComparison: TOnEqualityComparison; - const AExtendedHasher: TOnExtendedHasher): IExtendedEqualityComparer; overload; reintroduce; - class function Construct(const AEqualityComparison: TEqualityComparisonFunc; - const AExtendedHasher: TExtendedHasherFunc): IExtendedEqualityComparer; overload; reintroduce; - - procedure GetHashList(constref AValue: T; AHashList: PUInt32); virtual; abstract; - end; - - TDelegatedExtendedEqualityComparerEvents = class(TExtendedEqualityComparer) - private - FEqualityComparison: TOnEqualityComparison; - FHasher: TOnHasher; - FExtendedHasher: TOnExtendedHasher; - - function GetHashCodeMethod(constref AValue: T): UInt32; - public - function Equals(constref ALeft, ARight: T): Boolean; override; - function GetHashCode(constref AValue: T): UInt32; override; - procedure GetHashList(constref AValue: T; AHashList: PUInt32); override; - - constructor Create(const AEqualityComparison: TOnEqualityComparison; - const AHasher: TOnHasher; const AExtendedHasher: TOnExtendedHasher); overload; - constructor Create(const AEqualityComparison: TOnEqualityComparison; - const AExtendedHasher: TOnExtendedHasher); overload; - end; - - TDelegatedExtendedEqualityComparerFunc = class(TExtendedEqualityComparer) - private - FEqualityComparison: TEqualityComparisonFunc; - FHasher: THasherFunc; - FExtendedHasher: TExtendedHasherFunc; - public - function Equals(constref ALeft, ARight: T): Boolean; override; - function GetHashCode(constref AValue: T): UInt32; override; - procedure GetHashList(constref AValue: T; AHashList: PUInt32); override; - - constructor Create(const AEqualityComparison: TEqualityComparisonFunc; - const AHasher: THasherFunc; const AExtendedHasher: TExtendedHasherFunc); overload; - constructor Create(const AEqualityComparison: TEqualityComparisonFunc; - const AExtendedHasher: TExtendedHasherFunc); overload; - end; - - { TDelphiHashFactory } - - TDelphiHashFactory = class(THashFactory) - public - class function GetHashService: THashServiceClass; override; - class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; - end; - - { TGenericsHashFactory } - - TGenericsHashFactory = class(THashFactory) - public - class function GetHashService: THashServiceClass; override; - class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; - end; - - { TxxHash32HashFactory } - - TxxHash32HashFactory = class(THashFactory) - public - class function GetHashService: THashServiceClass; override; - class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; - end; - - { TxxHash32PascalHashFactory } - - TxxHash32PascalHashFactory = class(THashFactory) - public - class function GetHashService: THashServiceClass; override; - class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; - end; - - { TAdler32HashFactory } - - TAdler32HashFactory = class(THashFactory) - public - class function GetHashService: THashServiceClass; override; - class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; - end; - - { TSdbmHashFactory } - - TSdbmHashFactory = class(THashFactory) - public - class function GetHashService: THashServiceClass; override; - class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; - end; - - { TSdbmHashFactory } - - TSimpleChecksumFactory = class(THashFactory) - public - class function GetHashService: THashServiceClass; override; - class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; - end; - - { TDelphiDoubleHashFactory } - - TDelphiDoubleHashFactory = class(TExtendedHashFactory) - public - const MAX_HASHLIST_COUNT = 2; - const HASH_FUNCTIONS_COUNT = 1; - const HASHLIST_COUNT_PER_FUNCTION: array[1..HASH_FUNCTIONS_COUNT] of Integer = (2); - const HASH_FUNCTIONS_MASK_SIZE = 1; - const HASH_FUNCTIONS_MASK = 1; // 00000001b - - class function GetHashService: THashServiceClass; override; - class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; - class procedure GetHashList(AKey: Pointer; ASize: SizeInt; AHashList: PUInt32; AOptions: TGetHashListOptions = []); override; - end; - - TDelphiQuadrupleHashFactory = class(TExtendedHashFactory) - public - const MAX_HASHLIST_COUNT = 4; - const HASH_FUNCTIONS_COUNT = 2; - const HASHLIST_COUNT_PER_FUNCTION: array[1..HASH_FUNCTIONS_COUNT] of Integer = (2, 2); - const HASH_FUNCTIONS_MASK_SIZE = 2; - const HASH_FUNCTIONS_MASK = 3; // 00000011b - - class function GetHashService: THashServiceClass; override; - class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; - class procedure GetHashList(AKey: Pointer; ASize: SizeInt; AHashList: PUInt32; AOptions: TGetHashListOptions = []); override; - end; - - TDelphiSixfoldHashFactory = class(TExtendedHashFactory) - public - const MAX_HASHLIST_COUNT = 6; - const HASH_FUNCTIONS_COUNT = 3; - const HASHLIST_COUNT_PER_FUNCTION: array[1..HASH_FUNCTIONS_COUNT] of Integer = (2, 2, 2); - const HASH_FUNCTIONS_MASK_SIZE = 3; - const HASH_FUNCTIONS_MASK = 7; // 00000111b - - class function GetHashService: THashServiceClass; override; - class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; - class procedure GetHashList(AKey: Pointer; ASize: SizeInt; AHashList: PUInt32; AOptions: TGetHashListOptions = []); override; - end; - - TDefaultHashFactory = TGenericsHashFactory; - - TDefaultGenericInterface = (giComparer, giEqualityComparer, giExtendedEqualityComparer); - - TCustomComparer = class(TSingletonImplementation, IComparer, IEqualityComparer, IExtendedEqualityComparer) - protected - function Compare(constref Left, Right: T): Integer; virtual; abstract; - function Equals(constref Left, Right: T): Boolean; reintroduce; overload; virtual; abstract; - function GetHashCode(constref Value: T): UInt32; reintroduce; overload; virtual; abstract; - procedure GetHashList(constref Value: T; AHashList: PUInt32); virtual; abstract; - end; - - TOrdinalComparer = class(TCustomComparer) - protected class var - FComparer: IComparer; - FEqualityComparer: IEqualityComparer; - FExtendedEqualityComparer: IExtendedEqualityComparer; - - class constructor Create; - public - class function Ordinal: TCustomComparer; virtual; abstract; - end; - - // TGStringComparer will be renamed to TStringComparer -> bug #26030 - // anyway class var can't be used safely -> bug #24848 - - TGStringComparer = class(TOrdinalComparer) - private class var - FOrdinal: TCustomComparer; - class destructor Destroy; - public - class function Ordinal: TCustomComparer; override; - end; - - TGStringComparer = class(TGStringComparer); - TStringComparer = class(TGStringComparer); - TAnsiStringComparer = class(TGStringComparer); - TUnicodeStringComparer = class(TGStringComparer); - - { TGOrdinalStringComparer } - - // TGOrdinalStringComparer will be renamed to TOrdinalStringComparer -> bug #26030 - // anyway class var can't be used safely -> bug #24848 - TGOrdinalStringComparer = class(TGStringComparer) - public - function Compare(constref ALeft, ARight: T): Integer; override; - function Equals(constref ALeft, ARight: T): Boolean; overload; override; - function GetHashCode(constref AValue: T): UInt32; overload; override; - procedure GetHashList(constref AValue: T; AHashList: PUInt32); override; - end; - - TGOrdinalStringComparer = class(TGOrdinalStringComparer); - TOrdinalStringComparer = class(TGOrdinalStringComparer); - - TGIStringComparer = class(TOrdinalComparer) - private class var - FOrdinal: TCustomComparer; - class destructor Destroy; - public - class function Ordinal: TCustomComparer; override; - end; - - TGIStringComparer = class(TGIStringComparer); - TIStringComparer = class(TGIStringComparer); - TIAnsiStringComparer = class(TGIStringComparer); - TIUnicodeStringComparer = class(TGIStringComparer); - - TGOrdinalIStringComparer = class(TGIStringComparer) - public - function Compare(constref ALeft, ARight: T): Integer; override; - function Equals(constref ALeft, ARight: T): Boolean; overload; override; - function GetHashCode(constref AValue: T): UInt32; overload; override; - procedure GetHashList(constref AValue: T; AHashList: PUInt32); override; - end; - - TGOrdinalIStringComparer = class(TGOrdinalIStringComparer); - TOrdinalIStringComparer = class(TGOrdinalIStringComparer); - -// Delphi version of Bob Jenkins Hash -function BobJenkinsHash(const AData; ALength, AInitData: Integer): Integer; // same result as HashLittle_Delphi, just different interface -function BinaryCompare(const ALeft, ARight: Pointer; ASize: PtrUInt): Integer; inline; - -function _LookupVtableInfo(AGInterface: TDefaultGenericInterface; ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; inline; -function _LookupVtableInfoEx(AGInterface: TDefaultGenericInterface; ATypeInfo: PTypeInfo; ASize: SizeInt; - AFactory: THashFactoryClass): Pointer; - -implementation - -{ TComparer } - -class function TComparer.Default: IComparer; -begin - Result := _LookupVtableInfo(giComparer, TypeInfo(T), SizeOf(T)); -end; - -class function TComparer.Construct(const AComparison: TOnComparison): IComparer; -begin - Result := TDelegatedComparerEvents.Create(AComparison); -end; - -class function TComparer.Construct(const AComparison: TComparisonFunc): IComparer; -begin - Result := TDelegatedComparerFunc.Create(AComparison); -end; - -function TDelegatedComparerEvents.Compare(constref ALeft, ARight: T): Integer; -begin - Result := FComparison(ALeft, ARight); -end; - -constructor TDelegatedComparerEvents.Create(AComparison: TOnComparison); -begin - FComparison := AComparison; -end; - -function TDelegatedComparerFunc.Compare(constref ALeft, ARight: T): Integer; -begin - Result := FComparison(ALeft, ARight); -end; - -constructor TDelegatedComparerFunc.Create(AComparison: TComparisonFunc); -begin - FComparison := AComparison; -end; - -{ TInterface } - -function TInterface.QueryInterface(constref IID: TGUID; out Obj): HResult; -begin - Result := E_NOINTERFACE; -end; - -{ TRawInterface } - -function TRawInterface._AddRef: LongInt; -begin - Result := -1; -end; - -function TRawInterface._Release: LongInt; -begin - Result := -1; -end; - -{ TComTypeSizeInterface } - -function TComTypeSizeInterface._AddRef: LongInt; -var - _self: TComparerService.PSpoofInterfacedTypeSizeObject absolute Self; -begin - Result := InterLockedIncrement(_self.RefCount); -end; - -function TComTypeSizeInterface._Release: LongInt; -var - _self: TComparerService.PSpoofInterfacedTypeSizeObject absolute Self; -begin - Result := InterLockedDecrement(_self.RefCount); - if _self.RefCount = 0 then - Dispose(_self); -end; - -{ TSingletonImplementation } - -function TSingletonImplementation.QueryInterface(constref IID: TGUID; out Obj): HResult; -begin - if GetInterface(IID, Obj) then - Result := S_OK - else - Result := E_NOINTERFACE; -end; - -{ TCompare } - -(*********************************************************************************************************************** - Comparers -(**********************************************************************************************************************) - -{----------------------------------------------------------------------------------------------------------------------- - Comparers Int8 - Int32 and UInt8 - UInt32 -{----------------------------------------------------------------------------------------------------------------------} - -class function TCompare.Integer(constref ALeft, ARight: Integer): Integer; -begin - Result := Math.CompareValue(ALeft, ARight); -end; - -class function TCompare.Int8(constref ALeft, ARight: Int8): Integer; -begin - Result := ALeft - ARight; -end; - -class function TCompare.Int16(constref ALeft, ARight: Int16): Integer; -begin - Result := ALeft - ARight; -end; - -class function TCompare.Int32(constref ALeft, ARight: Int32): Integer; -begin - if ALeft > ARight then - Exit(1) - else if ALeft < ARight then - Exit(-1) - else - Exit(0); -end; - -class function TCompare.Int64(constref ALeft, ARight: Int64): Integer; -begin - if ALeft > ARight then - Exit(1) - else if ALeft < ARight then - Exit(-1) - else - Exit(0); -end; - -class function TCompare.UInt8(constref ALeft, ARight: UInt8): Integer; -begin - Result := System.Integer(ALeft) - System.Integer(ARight); -end; - -class function TCompare.UInt16(constref ALeft, ARight: UInt16): Integer; -begin - Result := System.Integer(ALeft) - System.Integer(ARight); -end; - -class function TCompare.UInt32(constref ALeft, ARight: UInt32): Integer; -begin - if ALeft > ARight then - Exit(1) - else if ALeft < ARight then - Exit(-1) - else - Exit(0); -end; - -class function TCompare.UInt64(constref ALeft, ARight: UInt64): Integer; -begin - if ALeft > ARight then - Exit(1) - else if ALeft < ARight then - Exit(-1) - else - Exit(0); -end; - -{----------------------------------------------------------------------------------------------------------------------- - Comparers for Float types -{----------------------------------------------------------------------------------------------------------------------} - -class function TCompare.Single(constref ALeft, ARight: Single): Integer; -begin - if ALeft > ARight then - Exit(1) - else if ALeft < ARight then - Exit(-1) - else - Exit(0); -end; - -class function TCompare.Double(constref ALeft, ARight: Double): Integer; -begin - if ALeft > ARight then - Exit(1) - else if ALeft < ARight then - Exit(-1) - else - Exit(0); -end; - -class function TCompare.Extended(constref ALeft, ARight: Extended): Integer; -begin - if ALeft > ARight then - Exit(1) - else if ALeft < ARight then - Exit(-1) - else - Exit(0); -end; - -{----------------------------------------------------------------------------------------------------------------------- - Comparers for other number types -{----------------------------------------------------------------------------------------------------------------------} - -class function TCompare.Currency(constref ALeft, ARight: Currency): Integer; -begin - if ALeft > ARight then - Exit(1) - else if ALeft < ARight then - Exit(-1) - else - Exit(0); -end; - -class function TCompare.Comp(constref ALeft, ARight: Comp): Integer; -begin - if ALeft > ARight then - Exit(1) - else if ALeft < ARight then - Exit(-1) - else - Exit(0); -end; - -{----------------------------------------------------------------------------------------------------------------------- - Comparers for binary data (records etc) and dynamics arrays -{----------------------------------------------------------------------------------------------------------------------} - -class function TCompare._Binary(constref ALeft, ARight): Integer; -var - _self: TComparerService.PSpoofInterfacedTypeSizeObject absolute Self; -begin - Result := CompareMemRange(@ALeft, @ARight, _self.Size); -end; - -class function TCompare._DynArray(constref ALeft, ARight: Pointer): Integer; -var - _self: TComparerService.PSpoofInterfacedTypeSizeObject absolute Self; - LLength, LLeftLength, LRightLength: Integer; -begin - LLeftLength := DynArraySize(ALeft); - LRightLength := DynArraySize(ARight); - if LLeftLength > LRightLength then - LLength := LRightLength - else - LLength := LLeftLength; - - Result := CompareMemRange(ALeft, ARight, LLength * _self.Size); - - if Result = 0 then - Result := LLeftLength - LRightLength; -end; - -class function TCompare.Binary(constref ALeft, ARight; const ASize: SizeInt): Integer; -begin - Result := CompareMemRange(@ALeft, @ARight, ASize); -end; - -class function TCompare.DynArray(constref ALeft, ARight: Pointer; const AElementSize: SizeInt): Integer; -var - LLength, LLeftLength, LRightLength: Integer; -begin - LLeftLength := DynArraySize(ALeft); - LRightLength := DynArraySize(ARight); - if LLeftLength > LRightLength then - LLength := LRightLength - else - LLength := LLeftLength; - - Result := CompareMemRange(ALeft, ARight, LLength * AElementSize); - - if Result = 0 then - Result := LLeftLength - LRightLength; -end; - -{----------------------------------------------------------------------------------------------------------------------- - Comparers for string types -{----------------------------------------------------------------------------------------------------------------------} - -class function TCompare.ShortString1(constref ALeft, ARight: ShortString1): Integer; -begin - if ALeft > ARight then - Exit(1) - else if ALeft < ARight then - Exit(-1) - else - Exit(0); -end; - -class function TCompare.ShortString2(constref ALeft, ARight: ShortString2): Integer; -begin - if ALeft > ARight then - Exit(1) - else if ALeft < ARight then - Exit(-1) - else - Exit(0); -end; - -class function TCompare.ShortString3(constref ALeft, ARight: ShortString3): Integer; -begin - if ALeft > ARight then - Exit(1) - else if ALeft < ARight then - Exit(-1) - else - Exit(0); -end; - -class function TCompare.ShortString(constref ALeft, ARight: ShortString): Integer; -begin - if ALeft > ARight then - Exit(1) - else if ALeft < ARight then - Exit(-1) - else - Exit(0); -end; - -class function TCompare.&String(constref ALeft, ARight: String): Integer; -begin - Result := CompareStr(ALeft, ARight); -end; - -class function TCompare.AnsiString(constref ALeft, ARight: AnsiString): Integer; -begin - Result := AnsiCompareStr(ALeft, ARight); -end; - -class function TCompare.WideString(constref ALeft, ARight: WideString): Integer; -begin - Result := WideCompareStr(ALeft, ARight); -end; - -class function TCompare.UnicodeString(constref ALeft, ARight: UnicodeString): Integer; -begin - Result := UnicodeCompareStr(ALeft, ARight); -end; - -{----------------------------------------------------------------------------------------------------------------------- - Comparers for Delegates -{----------------------------------------------------------------------------------------------------------------------} - -class function TCompare.Method(constref ALeft, ARight: TMethod): Integer; -begin - Result := CompareMemRange(@ALeft, @ARight, SizeOf(System.TMethod)); -end; - -{----------------------------------------------------------------------------------------------------------------------- - Comparers for Variant -{----------------------------------------------------------------------------------------------------------------------} - -class function TCompare.Variant(constref ALeft, ARight: PVariant): Integer; -var - LLeftString, LRightString: string; -begin - try - case VarCompareValue(ALeft^, ARight^) of - vrGreaterThan: - Exit(1); - vrLessThan: - Exit(-1); - vrEqual: - Exit(0); - vrNotEqual: - if VarIsEmpty(ALeft^) or VarIsNull(ALeft^) then - Exit(1) - else - Exit(-1); - end; - except - try - LLeftString := ALeft^; - LRightString := ARight^; - Result := CompareStr(LLeftString, LRightString); - except - Result := CompareMemRange(ALeft, ARight, SizeOf(System.Variant)); - end; - end; -end; - -{----------------------------------------------------------------------------------------------------------------------- - Comparers for Pointer -{----------------------------------------------------------------------------------------------------------------------} - -class function TCompare.Pointer(constref ALeft, ARight: PtrUInt): Integer; -begin - if ALeft > ARight then - Exit(1) - else if ALeft < ARight then - Exit(-1) - else - Exit(0); -end; - -{ TEquals } - -(*********************************************************************************************************************** - Equality Comparers -(**********************************************************************************************************************) - -{----------------------------------------------------------------------------------------------------------------------- - Equality Comparers Int8 - Int32 and UInt8 - UInt32 -{----------------------------------------------------------------------------------------------------------------------} - -class function TEquals.Integer(constref ALeft, ARight: Integer): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.Int8(constref ALeft, ARight: Int8): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.Int16(constref ALeft, ARight: Int16): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.Int32(constref ALeft, ARight: Int32): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.Int64(constref ALeft, ARight: Int64): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.UInt8(constref ALeft, ARight: UInt8): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.UInt16(constref ALeft, ARight: UInt16): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.UInt32(constref ALeft, ARight: UInt32): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.UInt64(constref ALeft, ARight: UInt64): Boolean; -begin - Result := ALeft = ARight; -end; - -{----------------------------------------------------------------------------------------------------------------------- - Equality Comparers for Float types -{----------------------------------------------------------------------------------------------------------------------} - -class function TEquals.Single(constref ALeft, ARight: Single): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.Double(constref ALeft, ARight: Double): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.Extended(constref ALeft, ARight: Extended): Boolean; -begin - Result := ALeft = ARight; -end; - -{----------------------------------------------------------------------------------------------------------------------- - Equality Comparers for other number types -{----------------------------------------------------------------------------------------------------------------------} - -class function TEquals.Currency(constref ALeft, ARight: Currency): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.Comp(constref ALeft, ARight: Comp): Boolean; -begin - Result := ALeft = ARight; -end; - -{----------------------------------------------------------------------------------------------------------------------- - Equality Comparers for binary data (records etc) and dynamics arrays -{----------------------------------------------------------------------------------------------------------------------} - -class function TEquals._Binary(constref ALeft, ARight): Boolean; -var - _self: TComparerService.PSpoofInterfacedTypeSizeObject absolute Self; -begin - Result := CompareMem(@ALeft, @ARight, _self.Size); -end; - -class function TEquals._DynArray(constref ALeft, ARight: Pointer): Boolean; -var - _self: TComparerService.PSpoofInterfacedTypeSizeObject absolute Self; - LLength: Integer; -begin - LLength := DynArraySize(ALeft); - if LLength <> DynArraySize(ARight) then - Exit(False); - - Result := CompareMem(ALeft, ARight, LLength * _self.Size); -end; - -class function TEquals.Binary(constref ALeft, ARight; const ASize: SizeInt): Boolean; -begin - Result := CompareMem(@ALeft, @ARight, ASize); -end; - -class function TEquals.DynArray(constref ALeft, ARight: Pointer; const AElementSize: SizeInt): Boolean; -var - LLength: Integer; -begin - LLength := DynArraySize(ALeft); - if LLength <> DynArraySize(ARight) then - Exit(False); - - Result := CompareMem(ALeft, ARight, LLength * AElementSize); -end; - -{----------------------------------------------------------------------------------------------------------------------- - Equality Comparers for classes -{----------------------------------------------------------------------------------------------------------------------} - -class function TEquals.&class(constref ALeft, ARight: TObject): Boolean; -begin - if ALeft <> nil then - Exit(ALeft.Equals(ARight)) - else - Exit(ARight = nil); -end; - -{----------------------------------------------------------------------------------------------------------------------- - Equality Comparers for string types -{----------------------------------------------------------------------------------------------------------------------} - -class function TEquals.ShortString1(constref ALeft, ARight: ShortString1): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.ShortString2(constref ALeft, ARight: ShortString2): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.ShortString3(constref ALeft, ARight: ShortString3): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.&String(constref ALeft, ARight: String): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.ShortString(constref ALeft, ARight: ShortString): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.AnsiString(constref ALeft, ARight: AnsiString): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.WideString(constref ALeft, ARight: WideString): Boolean; -begin - Result := ALeft = ARight; -end; - -class function TEquals.UnicodeString(constref ALeft, ARight: UnicodeString): Boolean; -begin - Result := ALeft = ARight; -end; - -{----------------------------------------------------------------------------------------------------------------------- - Equality Comparers for Delegates -{----------------------------------------------------------------------------------------------------------------------} - -class function TEquals.Method(constref ALeft, ARight: TMethod): Boolean; -begin - Result := (ALeft.Code = ARight.Code) and (ALeft.Data = ARight.Data); -end; - -{----------------------------------------------------------------------------------------------------------------------- - Equality Comparers for Variant -{----------------------------------------------------------------------------------------------------------------------} - -class function TEquals.Variant(constref ALeft, ARight: PVariant): Boolean; -begin - Result := VarCompareValue(ALeft^, ARight^) = vrEqual; -end; - -{----------------------------------------------------------------------------------------------------------------------- - Equality Comparers for Pointer -{----------------------------------------------------------------------------------------------------------------------} - -class function TEquals.Pointer(constref ALeft, ARight: PtrUInt): Boolean; -begin - Result := ALeft = ARight; -end; - -(*********************************************************************************************************************** - Hashes -(**********************************************************************************************************************) - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode Int8 - Int32 and UInt8 - UInt32 -{----------------------------------------------------------------------------------------------------------------------} - -class function THashFactory.Int8(constref AValue: Int8): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.Int8), 0); -end; - -class function THashFactory.Int16(constref AValue: Int16): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.Int16), 0); -end; - -class function THashFactory.Int32(constref AValue: Int32): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.Int32), 0); -end; - -class function THashFactory.Int64(constref AValue: Int64): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.Int64), 0); -end; - -class function THashFactory.UInt8(constref AValue: UInt8): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.UInt8), 0); -end; - -class function THashFactory.UInt16(constref AValue: UInt16): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.UInt16), 0); -end; - -class function THashFactory.UInt32(constref AValue: UInt32): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.UInt32), 0); -end; - -class function THashFactory.UInt64(constref AValue: UInt64): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.UInt64), 0); -end; - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode for Float types -{----------------------------------------------------------------------------------------------------------------------} - -class function THashFactory.Single(constref AValue: Single): UInt32; -var - LMantissa: Float; - LExponent: Integer; -begin - Frexp(AValue, LMantissa, LExponent); - - if LMantissa = 0 then - LMantissa := Abs(LMantissa); - - Result := HASH_FACTORY.GetHashCode(@LMantissa, SizeOf(Math.Float), 0); - Result := HASH_FACTORY.GetHashCode(@LExponent, SizeOf(System.Integer), Result); -end; - -class function THashFactory.Double(constref AValue: Double): UInt32; -var - LMantissa: Float; - LExponent: Integer; -begin - Frexp(AValue, LMantissa, LExponent); - - if LMantissa = 0 then - LMantissa := Abs(LMantissa); - - Result := HASH_FACTORY.GetHashCode(@LMantissa, SizeOf(Math.Float), 0); - Result := HASH_FACTORY.GetHashCode(@LExponent, SizeOf(System.Integer), Result); -end; - -class function THashFactory.Extended(constref AValue: Extended): UInt32; -var - LMantissa: Float; - LExponent: Integer; -begin - Frexp(AValue, LMantissa, LExponent); - - if LMantissa = 0 then - LMantissa := Abs(LMantissa); - - Result := HASH_FACTORY.GetHashCode(@LMantissa, SizeOf(Math.Float), 0); - Result := HASH_FACTORY.GetHashCode(@LExponent, SizeOf(System.Integer), Result); -end; - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode for other number types -{----------------------------------------------------------------------------------------------------------------------} - -class function THashFactory.Currency(constref AValue: Currency): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.Int64), 0); -end; - -class function THashFactory.Comp(constref AValue: Comp): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.Int64), 0); -end; - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode for binary data (records etc) and dynamics arrays -{----------------------------------------------------------------------------------------------------------------------} - -class function THashFactory.Binary(constref AValue): UInt32; -var - _self: TComparerService.PSpoofInterfacedTypeSizeObject absolute Self; -begin - Result := HASH_FACTORY.GetHashCode(@AValue, _self.Size, 0); -end; - -class function THashFactory.DynArray(constref AValue: Pointer): UInt32; -var - _self: TComparerService.PSpoofInterfacedTypeSizeObject absolute Self; -begin - Result := HASH_FACTORY.GetHashCode(AValue, DynArraySize(AValue) * _self.Size, 0); -end; - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode for classes -{----------------------------------------------------------------------------------------------------------------------} - -class function THashFactory.&Class(constref AValue: TObject): UInt32; -begin - if AValue = nil then - Exit($2A); - - Result := AValue.GetHashCode; -end; - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode for string types -{----------------------------------------------------------------------------------------------------------------------} - -class function THashFactory.ShortString1(constref AValue: ShortString1): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue[1], Length(AValue), 0); -end; - -class function THashFactory.ShortString2(constref AValue: ShortString2): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue[1], Length(AValue), 0); -end; - -class function THashFactory.ShortString3(constref AValue: ShortString3): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue[1], Length(AValue), 0); -end; - -class function THashFactory.ShortString(constref AValue: ShortString): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue[1], Length(AValue), 0); -end; - -class function THashFactory.AnsiString(constref AValue: AnsiString): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue[1], Length(AValue) * SizeOf(System.AnsiChar), 0); -end; - -class function THashFactory.WideString(constref AValue: WideString): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue[1], Length(AValue) * SizeOf(System.WideChar), 0); -end; - -class function THashFactory.UnicodeString(constref AValue: UnicodeString): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue[1], Length(AValue) * SizeOf(System.UnicodeChar), 0); -end; - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode for Delegates -{----------------------------------------------------------------------------------------------------------------------} - -class function THashFactory.Method(constref AValue: TMethod): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.TMethod), 0); -end; - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode for Variant -{----------------------------------------------------------------------------------------------------------------------} - -class function THashFactory.Variant(constref AValue: PVariant): UInt32; -begin - try - Result := HASH_FACTORY.UnicodeString(AValue^); - except - Result := HASH_FACTORY.GetHashCode(AValue, SizeOf(System.Variant), 0); - end; -end; - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode for Pointer -{----------------------------------------------------------------------------------------------------------------------} - -class function THashFactory.Pointer(constref AValue: Pointer): UInt32; -begin - Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.Pointer), 0); -end; - -{ TExtendedHashFactory } - -(*********************************************************************************************************************** - Hashes 2 -(**********************************************************************************************************************) - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode Int8 - Int32 and UInt8 - UInt32 -{----------------------------------------------------------------------------------------------------------------------} - -class procedure TExtendedHashFactory.Int8(constref AValue: Int8; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.Int8), AHashList, []); -end; - -class procedure TExtendedHashFactory.Int16(constref AValue: Int16; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.Int16), AHashList, []); -end; - -class procedure TExtendedHashFactory.Int32(constref AValue: Int32; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.Int32), AHashList, []); -end; - -class procedure TExtendedHashFactory.Int64(constref AValue: Int64; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.Int64), AHashList, []); -end; - -class procedure TExtendedHashFactory.UInt8(constref AValue: UInt8; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.UInt8), AHashList, []); -end; - -class procedure TExtendedHashFactory.UInt16(constref AValue: UInt16; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.UInt16), AHashList, []); -end; - -class procedure TExtendedHashFactory.UInt32(constref AValue: UInt32; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.UInt32), AHashList, []); -end; - -class procedure TExtendedHashFactory.UInt64(constref AValue: UInt64; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.UInt64), AHashList, []); -end; - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode for Float types -{----------------------------------------------------------------------------------------------------------------------} - -class procedure TExtendedHashFactory.Single(constref AValue: Single; AHashList: PUInt32); -var - LMantissa: Float; - LExponent: Integer; -begin - Frexp(AValue, LMantissa, LExponent); - - if LMantissa = 0 then - LMantissa := Abs(LMantissa); - - EXTENDED_HASH_FACTORY.GetHashList(@LMantissa, SizeOf(Math.Float), AHashList, []); - EXTENDED_HASH_FACTORY.GetHashList(@LExponent, SizeOf(System.Integer), AHashList, [ghloHashListAsInitData]); -end; - -class procedure TExtendedHashFactory.Double(constref AValue: Double; AHashList: PUInt32); -var - LMantissa: Float; - LExponent: Integer; -begin - Frexp(AValue, LMantissa, LExponent); - - if LMantissa = 0 then - LMantissa := Abs(LMantissa); - - EXTENDED_HASH_FACTORY.GetHashList(@LMantissa, SizeOf(Math.Float), AHashList, []); - EXTENDED_HASH_FACTORY.GetHashList(@LExponent, SizeOf(System.Integer), AHashList, [ghloHashListAsInitData]); -end; - -class procedure TExtendedHashFactory.Extended(constref AValue: Extended; AHashList: PUInt32); -var - LMantissa: Float; - LExponent: Integer; -begin - Frexp(AValue, LMantissa, LExponent); - - if LMantissa = 0 then - LMantissa := Abs(LMantissa); - - EXTENDED_HASH_FACTORY.GetHashList(@LMantissa, SizeOf(Math.Float), AHashList, []); - EXTENDED_HASH_FACTORY.GetHashList(@LExponent, SizeOf(System.Integer), AHashList, [ghloHashListAsInitData]); -end; - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode for other number types -{----------------------------------------------------------------------------------------------------------------------} - -class procedure TExtendedHashFactory.Currency(constref AValue: Currency; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.Int64), AHashList, []); -end; - -class procedure TExtendedHashFactory.Comp(constref AValue: Comp; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.Int64), AHashList, []); -end; - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode for binary data (records etc) and dynamics arrays -{----------------------------------------------------------------------------------------------------------------------} - -class procedure TExtendedHashFactory.Binary(constref AValue; AHashList: PUInt32); -var - _self: TComparerService.PSpoofInterfacedTypeSizeObject absolute Self; -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue, _self.Size, AHashList, []); -end; - -class procedure TExtendedHashFactory.DynArray(constref AValue: Pointer; AHashList: PUInt32); -var - _self: TComparerService.PSpoofInterfacedTypeSizeObject absolute Self; -begin - EXTENDED_HASH_FACTORY.GetHashList(AValue, DynArraySize(AValue) * _self.Size, AHashList, []); -end; - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode for classes -{----------------------------------------------------------------------------------------------------------------------} - -class procedure TExtendedHashFactory.&Class(constref AValue: TObject; AHashList: PUInt32); -var - LValue: PtrInt; -begin - if AValue = nil then - begin - LValue := $2A; - EXTENDED_HASH_FACTORY.GetHashList(@LValue, SizeOf(LValue), AHashList, []); - Exit; - end; - - LValue := AValue.GetHashCode; - EXTENDED_HASH_FACTORY.GetHashList(@LValue, SizeOf(LValue), AHashList, []); -end; - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode for string types -{----------------------------------------------------------------------------------------------------------------------} - -class procedure TExtendedHashFactory.ShortString1(constref AValue: ShortString1; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue[1], Length(AValue), AHashList, []); -end; - -class procedure TExtendedHashFactory.ShortString2(constref AValue: ShortString2; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue[1], Length(AValue), AHashList, []); -end; - -class procedure TExtendedHashFactory.ShortString3(constref AValue: ShortString3; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue[1], Length(AValue), AHashList, []); -end; - -class procedure TExtendedHashFactory.ShortString(constref AValue: ShortString; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue[1], Length(AValue), AHashList, []); -end; - -class procedure TExtendedHashFactory.AnsiString(constref AValue: AnsiString; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue[1], Length(AValue) * SizeOf(System.AnsiChar), AHashList, []); -end; - -class procedure TExtendedHashFactory.WideString(constref AValue: WideString; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue[1], Length(AValue) * SizeOf(System.WideChar), AHashList, []); -end; - -class procedure TExtendedHashFactory.UnicodeString(constref AValue: UnicodeString; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue[1], Length(AValue) * SizeOf(System.UnicodeChar), AHashList, []); -end; - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode for Delegates -{----------------------------------------------------------------------------------------------------------------------} - -class procedure TExtendedHashFactory.Method(constref AValue: TMethod; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.TMethod), AHashList, []); -end; - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode for Variant -{----------------------------------------------------------------------------------------------------------------------} - -class procedure TExtendedHashFactory.Variant(constref AValue: PVariant; AHashList: PUInt32); -begin - try - EXTENDED_HASH_FACTORY.UnicodeString(AValue^, AHashList); - except - EXTENDED_HASH_FACTORY.GetHashList(AValue, SizeOf(System.Variant), AHashList, []); - end; -end; - -{----------------------------------------------------------------------------------------------------------------------- - GetHashCode for Pointer -{----------------------------------------------------------------------------------------------------------------------} - -class procedure TExtendedHashFactory.Pointer(constref AValue: Pointer; AHashList: PUInt32); -begin - EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.Pointer), AHashList, []); -end; - -{ TComparerService } - -class function TComparerService.CreateInterface(AVMT: Pointer; ASize: SizeInt): PSpoofInterfacedTypeSizeObject; -begin - Result := New(PSpoofInterfacedTypeSizeObject); - Result.VMT := AVMT; - Result.RefCount := 0; - Result.Size := ASize; -end; - -class function TComparerService.SelectIntegerComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; -begin - case ATypeData.OrdType of - otSByte: - Exit(@Comparer_Int8_Instance); - otUByte: - Exit(@Comparer_UInt8_Instance); - otSWord: - Exit(@Comparer_Int16_Instance); - otUWord: - Exit(@Comparer_UInt16_Instance); - otSLong: - Exit(@Comparer_Int32_Instance); - otULong: - Exit(@Comparer_UInt32_Instance); - else - System.Error(reRangeError); - Exit(nil); - end; -end; - -class function TComparerService.SelectInt64Comparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; -begin - if ATypeData.MaxInt64Value > ATypeData.MinInt64Value then - Exit(@Comparer_Int64_Instance) - else - Exit(@Comparer_UInt64_Instance); -end; - -class function TComparerService.SelectFloatComparer(ATypeData: PTypeData; - ASize: SizeInt): Pointer; -begin - case ATypeData.FloatType of - ftSingle: - Exit(@Comparer_Single_Instance); - ftDouble: - Exit(@Comparer_Double_Instance); - ftExtended: - Exit(@Comparer_Extended_Instance); - ftComp: - Exit(@Comparer_Comp_Instance); - ftCurr: - Exit(@Comparer_Currency_Instance); - else - System.Error(reRangeError); - Exit(nil); - end; -end; - -class function TComparerService.SelectShortStringComparer(ATypeData: PTypeData; - ASize: SizeInt): Pointer; -begin - case ASize of - 2: Exit(@Comparer_ShortString1_Instance); - 3: Exit(@Comparer_ShortString2_Instance); - 4: Exit(@Comparer_ShortString3_Instance); - else - Exit(@Comparer_ShortString_Instance); - end; -end; - -class function TComparerService.SelectBinaryComparer(ATypeData: PTypeData; - ASize: SizeInt): Pointer; -begin - case ASize of - 1: Exit(@Comparer_UInt8_Instance); - 2: Exit(@Comparer_UInt16_Instance); - 4: Exit(@Comparer_UInt32_Instance); -{$IFDEF CPU64} - 8: Exit(@Comparer_UInt64_Instance) -{$ENDIF} - else - Result := CreateInterface(@Comparer_Binary_VMT, ASize); - end; -end; - -class function TComparerService.SelectDynArrayComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; -begin - Result := CreateInterface(@Comparer_DynArray_VMT, ATypeData.elSize); -end; - -class function TComparerService.LookupComparer(ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; -var - LInstance: PInstance; -begin - if ATypeInfo = nil then - Exit(SelectBinaryComparer(GetTypeData(ATypeInfo), ASize)) - else - begin - LInstance := @ComparerInstances[ATypeInfo.Kind]; - Result := LInstance.Instance; - if LInstance.Selector then - Result := TSelectFunc(Result)(GetTypeData(ATypeInfo), ASize); - end; -end; - -{ TComparerService.TInstance } - -class function TComparerService.TInstance.Create(ASelector: Boolean; - AInstance: Pointer): TComparerService.TInstance; -begin - Result.Selector := ASelector; - Result.Instance := AInstance; -end; - -class function TComparerService.TInstance.CreateSelector(ASelectorInstance: CodePointer): TComparerService.TInstance; -begin - Result.Selector := True; - Result.SelectorInstance := ASelectorInstance; -end; - -{ TExtendedHashService } - -class function TExtendedHashService.LookupEqualityComparer(ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; -begin - Result := LookupExtendedEqualityComparer(ATypeInfo, ASize); -end; - -{ THashService } - -class function THashService.SelectIntegerEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; -begin - case ATypeData.OrdType of - otSByte: - Exit(@FEqualityComparer_Int8_Instance); - otUByte: - Exit(@FEqualityComparer_UInt8_Instance); - otSWord: - Exit(@FEqualityComparer_Int16_Instance); - otUWord: - Exit(@FEqualityComparer_UInt16_Instance); - otSLong: - Exit(@FEqualityComparer_Int32_Instance); - otULong: - Exit(@FEqualityComparer_UInt32_Instance); - else - System.Error(reRangeError); - Exit(nil); - end; -end; - -class function THashService.SelectFloatEqualityComparer(ATypeData: PTypeData; - ASize: SizeInt): Pointer; -begin - case ATypeData.FloatType of - ftSingle: - Exit(@FEqualityComparer_Single_Instance); - ftDouble: - Exit(@FEqualityComparer_Double_Instance); - ftExtended: - Exit(@FEqualityComparer_Extended_Instance); - ftComp: - Exit(@FEqualityComparer_Comp_Instance); - ftCurr: - Exit(@FEqualityComparer_Currency_Instance); - else - System.Error(reRangeError); - Exit(nil); - end; -end; - -class function THashService.SelectShortStringEqualityComparer( - ATypeData: PTypeData; ASize: SizeInt): Pointer; -begin - case ASize of - 2: Exit(@FEqualityComparer_ShortString1_Instance); - 3: Exit(@FEqualityComparer_ShortString2_Instance); - 4: Exit(@FEqualityComparer_ShortString3_Instance); - else - Exit(@FEqualityComparer_ShortString_Instance); - end -end; - -class function THashService.SelectBinaryEqualityComparer(ATypeData: PTypeData; - ASize: SizeInt): Pointer; -begin - case ASize of - 1: Exit(@FEqualityComparer_UInt8_Instance); - 2: Exit(@FEqualityComparer_UInt16_Instance); - 4: Exit(@FEqualityComparer_UInt32_Instance); -{$IFDEF CPU64} - 8: Exit(@FEqualityComparer_UInt64_Instance) -{$ENDIF} - else - Result := CreateInterface(@FEqualityComparer_Binary_VMT, ASize); - end; -end; - -class function THashService.SelectDynArrayEqualityComparer( - ATypeData: PTypeData; ASize: SizeInt): Pointer; -begin - Result := CreateInterface(@FEqualityComparer_DynArray_VMT, ATypeData.elSize); -end; - -class function THashService.LookupEqualityComparer(ATypeInfo: PTypeInfo; - ASize: SizeInt): Pointer; -var - LInstance: PInstance; - LSelectMethod: TSelectMethod; -begin - if ATypeInfo = nil then - Exit(SelectBinaryEqualityComparer(GetTypeData(ATypeInfo), ASize)) - else - begin - LInstance := @FEqualityComparerInstances[ATypeInfo.Kind]; - Result := LInstance.Instance; - if LInstance.Selector then - begin - TMethod(LSelectMethod).Code := LInstance.SelectorInstance; - TMethod(LSelectMethod).Data := Self; - Result := LSelectMethod(GetTypeData(ATypeInfo), ASize); - end; - end; -end; - -class constructor THashService.Create; -begin - FEqualityComparer_Int8_VMT := EqualityComparer_Int8_VMT ; - FEqualityComparer_Int16_VMT := EqualityComparer_Int16_VMT ; - FEqualityComparer_Int32_VMT := EqualityComparer_Int32_VMT ; - FEqualityComparer_Int64_VMT := EqualityComparer_Int64_VMT ; - FEqualityComparer_UInt8_VMT := EqualityComparer_UInt8_VMT ; - FEqualityComparer_UInt16_VMT := EqualityComparer_UInt16_VMT ; - FEqualityComparer_UInt32_VMT := EqualityComparer_UInt32_VMT ; - FEqualityComparer_UInt64_VMT := EqualityComparer_UInt64_VMT ; - FEqualityComparer_Single_VMT := EqualityComparer_Single_VMT ; - FEqualityComparer_Double_VMT := EqualityComparer_Double_VMT ; - FEqualityComparer_Extended_VMT := EqualityComparer_Extended_VMT ; - FEqualityComparer_Currency_VMT := EqualityComparer_Currency_VMT ; - FEqualityComparer_Comp_VMT := EqualityComparer_Comp_VMT ; - FEqualityComparer_Binary_VMT := EqualityComparer_Binary_VMT ; - FEqualityComparer_DynArray_VMT := EqualityComparer_DynArray_VMT ; - FEqualityComparer_Class_VMT := EqualityComparer_Class_VMT ; - FEqualityComparer_ShortString1_VMT := EqualityComparer_ShortString1_VMT ; - FEqualityComparer_ShortString2_VMT := EqualityComparer_ShortString2_VMT ; - FEqualityComparer_ShortString3_VMT := EqualityComparer_ShortString3_VMT ; - FEqualityComparer_ShortString_VMT := EqualityComparer_ShortString_VMT ; - FEqualityComparer_AnsiString_VMT := EqualityComparer_AnsiString_VMT ; - FEqualityComparer_WideString_VMT := EqualityComparer_WideString_VMT ; - FEqualityComparer_UnicodeString_VMT := EqualityComparer_UnicodeString_VMT; - FEqualityComparer_Method_VMT := EqualityComparer_Method_VMT ; - FEqualityComparer_Variant_VMT := EqualityComparer_Variant_VMT ; - FEqualityComparer_Pointer_VMT := EqualityComparer_Pointer_VMT ; - - ///// - FEqualityComparer_Int8_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_Int16_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_Int32_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_Int64_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_UInt8_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_UInt16_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_UInt32_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_UInt64_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_Single_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_Double_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_Extended_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_Currency_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_Comp_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_Binary_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_DynArray_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_Class_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_ShortString1_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_ShortString2_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_ShortString3_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_ShortString_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_AnsiString_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_WideString_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_UnicodeString_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_Method_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_Variant_VMT.__ClassRef := THashFactoryClass(T.ClassType); - FEqualityComparer_Pointer_VMT.__ClassRef := THashFactoryClass(T.ClassType); - - /////// - FEqualityComparer_Int8_Instance := @FEqualityComparer_Int8_VMT ; - FEqualityComparer_Int16_Instance := @FEqualityComparer_Int16_VMT ; - FEqualityComparer_Int32_Instance := @FEqualityComparer_Int32_VMT ; - FEqualityComparer_Int64_Instance := @FEqualityComparer_Int64_VMT ; - FEqualityComparer_UInt8_Instance := @FEqualityComparer_UInt8_VMT ; - FEqualityComparer_UInt16_Instance := @FEqualityComparer_UInt16_VMT ; - FEqualityComparer_UInt32_Instance := @FEqualityComparer_UInt32_VMT ; - FEqualityComparer_UInt64_Instance := @FEqualityComparer_UInt64_VMT ; - FEqualityComparer_Single_Instance := @FEqualityComparer_Single_VMT ; - FEqualityComparer_Double_Instance := @FEqualityComparer_Double_VMT ; - FEqualityComparer_Extended_Instance := @FEqualityComparer_Extended_VMT ; - FEqualityComparer_Currency_Instance := @FEqualityComparer_Currency_VMT ; - FEqualityComparer_Comp_Instance := @FEqualityComparer_Comp_VMT ; - //FEqualityComparer_Binary_Instance := @FEqualityComparer_Binary_VMT ; // dynamic instance - //FEqualityComparer_DynArray_Instance := @FEqualityComparer_DynArray_VMT ; // dynamic instance - FEqualityComparer_ShortString1_Instance := @FEqualityComparer_ShortString1_VMT ; - FEqualityComparer_ShortString2_Instance := @FEqualityComparer_ShortString2_VMT ; - FEqualityComparer_ShortString3_Instance := @FEqualityComparer_ShortString3_VMT ; - FEqualityComparer_ShortString_Instance := @FEqualityComparer_ShortString_VMT ; - FEqualityComparer_AnsiString_Instance := @FEqualityComparer_AnsiString_VMT ; - FEqualityComparer_WideString_Instance := @FEqualityComparer_WideString_VMT ; - FEqualityComparer_UnicodeString_Instance := @FEqualityComparer_UnicodeString_VMT; - FEqualityComparer_Method_Instance := @FEqualityComparer_Method_VMT ; - FEqualityComparer_Variant_Instance := @FEqualityComparer_Variant_VMT ; - FEqualityComparer_Pointer_Instance := @FEqualityComparer_Pointer_VMT ; - - ////// - FEqualityComparerInstances[tkUnknown] := TInstance.CreateSelector(TMethod(TSelectMethod(THashService.SelectBinaryEqualityComparer)).Code); - FEqualityComparerInstances[tkInteger] := TInstance.CreateSelector(TMethod(TSelectMethod(THashService.SelectIntegerEqualityComparer)).Code); - FEqualityComparerInstances[tkChar] := TInstance.Create(False, @FEqualityComparer_UInt8_Instance); - FEqualityComparerInstances[tkEnumeration] := TInstance.CreateSelector(TMethod(TSelectMethod(THashService.SelectIntegerEqualityComparer)).Code); - FEqualityComparerInstances[tkFloat] := TInstance.CreateSelector(TMethod(TSelectMethod(THashService.SelectFloatEqualityComparer)).Code); - FEqualityComparerInstances[tkSet] := TInstance.CreateSelector(TMethod(TSelectMethod(THashService.SelectBinaryEqualityComparer)).Code); - FEqualityComparerInstances[tkMethod] := TInstance.Create(False, @FEqualityComparer_Method_Instance); - FEqualityComparerInstances[tkSString] := TInstance.CreateSelector(TMethod(TSelectMethod(THashService.SelectShortStringEqualityComparer)).Code); - FEqualityComparerInstances[tkLString] := TInstance.Create(False, @FEqualityComparer_AnsiString_Instance); - FEqualityComparerInstances[tkAString] := TInstance.Create(False, @FEqualityComparer_AnsiString_Instance); - FEqualityComparerInstances[tkWString] := TInstance.Create(False, @FEqualityComparer_WideString_Instance); - FEqualityComparerInstances[tkVariant] := TInstance.Create(False, @FEqualityComparer_Variant_Instance); - FEqualityComparerInstances[tkArray] := TInstance.CreateSelector(TMethod(TSelectMethod(THashService.SelectBinaryEqualityComparer)).Code); - FEqualityComparerInstances[tkRecord] := TInstance.CreateSelector(TMethod(TSelectMethod(THashService.SelectBinaryEqualityComparer)).Code); - FEqualityComparerInstances[tkInterface] := TInstance.Create(False, @FEqualityComparer_Pointer_Instance); - FEqualityComparerInstances[tkClass] := TInstance.Create(False, @FEqualityComparer_Pointer_Instance); - FEqualityComparerInstances[tkObject] := TInstance.CreateSelector(TMethod(TSelectMethod(THashService.SelectBinaryEqualityComparer)).Code); - FEqualityComparerInstances[tkWChar] := TInstance.Create(False, @FEqualityComparer_UInt16_Instance); - FEqualityComparerInstances[tkBool] := TInstance.CreateSelector(TMethod(TSelectMethod(THashService.SelectIntegerEqualityComparer)).Code); - FEqualityComparerInstances[tkInt64] := TInstance.Create(False, @FEqualityComparer_Int64_Instance); - FEqualityComparerInstances[tkQWord] := TInstance.Create(False, @FEqualityComparer_UInt64_Instance); - FEqualityComparerInstances[tkDynArray] := TInstance.CreateSelector(TMethod(TSelectMethod(THashService.SelectDynArrayEqualityComparer)).Code); - FEqualityComparerInstances[tkInterfaceRaw] := TInstance.Create(False, @FEqualityComparer_Pointer_Instance); - FEqualityComparerInstances[tkProcVar] := TInstance.Create(False, @FEqualityComparer_Pointer_Instance); - FEqualityComparerInstances[tkUString] := TInstance.Create(False, @FEqualityComparer_UnicodeString_Instance); - FEqualityComparerInstances[tkUChar] := TInstance.Create(False, @FEqualityComparer_UInt16_Instance); - FEqualityComparerInstances[tkHelper] := TInstance.Create(False, @FEqualityComparer_Pointer_Instance); - FEqualityComparerInstances[tkFile] := TInstance.CreateSelector(TMethod(TSelectMethod(THashService.SelectBinaryEqualityComparer)).Code); - FEqualityComparerInstances[tkClassRef] := TInstance.Create(False, @FEqualityComparer_Pointer_Instance); - FEqualityComparerInstances[tkPointer] := TInstance.Create(False, @FEqualityComparer_Pointer_Instance) -end; - -{ TExtendedHashService } - -class function TExtendedHashService.SelectIntegerEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; -begin - case ATypeData.OrdType of - otSByte: - Exit(@FExtendedEqualityComparer_Int8_Instance); - otUByte: - Exit(@FExtendedEqualityComparer_UInt8_Instance); - otSWord: - Exit(@FExtendedEqualityComparer_Int16_Instance); - otUWord: - Exit(@FExtendedEqualityComparer_UInt16_Instance); - otSLong: - Exit(@FExtendedEqualityComparer_Int32_Instance); - otULong: - Exit(@FExtendedEqualityComparer_UInt32_Instance); - else - System.Error(reRangeError); - Exit(nil); - end; -end; - -class function TExtendedHashService.SelectFloatEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; -begin - case ATypeData.FloatType of - ftSingle: - Exit(@FExtendedEqualityComparer_Single_Instance); - ftDouble: - Exit(@FExtendedEqualityComparer_Double_Instance); - ftExtended: - Exit(@FExtendedEqualityComparer_Extended_Instance); - ftComp: - Exit(@FExtendedEqualityComparer_Comp_Instance); - ftCurr: - Exit(@FExtendedEqualityComparer_Currency_Instance); - else - System.Error(reRangeError); - Exit(nil); - end; -end; - -class function TExtendedHashService.SelectShortStringEqualityComparer(ATypeData: PTypeData; - ASize: SizeInt): Pointer; -begin - case ASize of - 2: Exit(@FExtendedEqualityComparer_ShortString1_Instance); - 3: Exit(@FExtendedEqualityComparer_ShortString2_Instance); - 4: Exit(@FExtendedEqualityComparer_ShortString3_Instance); - else - Exit(@FExtendedEqualityComparer_ShortString_Instance); - end -end; - -class function TExtendedHashService.SelectBinaryEqualityComparer(ATypeData: PTypeData; - ASize: SizeInt): Pointer; -begin - case ASize of - 1: Exit(@FExtendedEqualityComparer_UInt8_Instance); - 2: Exit(@FExtendedEqualityComparer_UInt16_Instance); - 4: Exit(@FExtendedEqualityComparer_UInt32_Instance); -{$IFDEF CPU64} - 8: Exit(@FExtendedEqualityComparer_UInt64_Instance) -{$ENDIF} - else - Result := CreateInterface(@FExtendedEqualityComparer_Binary_VMT, ASize); - end; -end; - -class function TExtendedHashService.SelectDynArrayEqualityComparer( - ATypeData: PTypeData; ASize: SizeInt): Pointer; -begin - Result := CreateInterface(@FExtendedEqualityComparer_DynArray_VMT, ATypeData.elSize); -end; - -class function TExtendedHashService.LookupExtendedEqualityComparer( - ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; -var - LInstance: PInstance; - LSelectMethod: TSelectMethod; -begin - if ATypeInfo = nil then - Exit(SelectBinaryEqualityComparer(GetTypeData(ATypeInfo), ASize)) - else - begin - LInstance := @FExtendedEqualityComparerInstances[ATypeInfo.Kind]; - Result := LInstance.Instance; - if LInstance.Selector then - begin - TMethod(LSelectMethod).Code := LInstance.SelectorInstance; - TMethod(LSelectMethod).Data := Self; - Result := LSelectMethod(GetTypeData(ATypeInfo), ASize); - end; - end; -end; - -class constructor TExtendedHashService.Create; -begin - FExtendedEqualityComparer_Int8_VMT := ExtendedEqualityComparer_Int8_VMT ; - FExtendedEqualityComparer_Int16_VMT := ExtendedEqualityComparer_Int16_VMT ; - FExtendedEqualityComparer_Int32_VMT := ExtendedEqualityComparer_Int32_VMT ; - FExtendedEqualityComparer_Int64_VMT := ExtendedEqualityComparer_Int64_VMT ; - FExtendedEqualityComparer_UInt8_VMT := ExtendedEqualityComparer_UInt8_VMT ; - FExtendedEqualityComparer_UInt16_VMT := ExtendedEqualityComparer_UInt16_VMT ; - FExtendedEqualityComparer_UInt32_VMT := ExtendedEqualityComparer_UInt32_VMT ; - FExtendedEqualityComparer_UInt64_VMT := ExtendedEqualityComparer_UInt64_VMT ; - FExtendedEqualityComparer_Single_VMT := ExtendedEqualityComparer_Single_VMT ; - FExtendedEqualityComparer_Double_VMT := ExtendedEqualityComparer_Double_VMT ; - FExtendedEqualityComparer_Extended_VMT := ExtendedEqualityComparer_Extended_VMT ; - FExtendedEqualityComparer_Currency_VMT := ExtendedEqualityComparer_Currency_VMT ; - FExtendedEqualityComparer_Comp_VMT := ExtendedEqualityComparer_Comp_VMT ; - FExtendedEqualityComparer_Binary_VMT := ExtendedEqualityComparer_Binary_VMT ; - FExtendedEqualityComparer_DynArray_VMT := ExtendedEqualityComparer_DynArray_VMT ; - FExtendedEqualityComparer_Class_VMT := ExtendedEqualityComparer_Class_VMT ; - FExtendedEqualityComparer_ShortString1_VMT := ExtendedEqualityComparer_ShortString1_VMT ; - FExtendedEqualityComparer_ShortString2_VMT := ExtendedEqualityComparer_ShortString2_VMT ; - FExtendedEqualityComparer_ShortString3_VMT := ExtendedEqualityComparer_ShortString3_VMT ; - FExtendedEqualityComparer_ShortString_VMT := ExtendedEqualityComparer_ShortString_VMT ; - FExtendedEqualityComparer_AnsiString_VMT := ExtendedEqualityComparer_AnsiString_VMT ; - FExtendedEqualityComparer_WideString_VMT := ExtendedEqualityComparer_WideString_VMT ; - FExtendedEqualityComparer_UnicodeString_VMT := ExtendedEqualityComparer_UnicodeString_VMT; - FExtendedEqualityComparer_Method_VMT := ExtendedEqualityComparer_Method_VMT ; - FExtendedEqualityComparer_Variant_VMT := ExtendedEqualityComparer_Variant_VMT ; - FExtendedEqualityComparer_Pointer_VMT := ExtendedEqualityComparer_Pointer_VMT ; - - ///// - FExtendedEqualityComparer_Int8_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_Int16_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_Int32_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_Int64_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_UInt8_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_UInt16_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_UInt32_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_UInt64_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_Single_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_Double_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_Extended_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_Currency_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_Comp_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_Binary_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_DynArray_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_Class_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_ShortString1_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_ShortString2_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_ShortString3_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_ShortString_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_AnsiString_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_WideString_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_UnicodeString_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_Method_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_Variant_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - FExtendedEqualityComparer_Pointer_VMT.__ClassRef := TExtendedHashFactoryClass(T.ClassType); - - /////// - FExtendedEqualityComparer_Int8_Instance := @FExtendedEqualityComparer_Int8_VMT ; - FExtendedEqualityComparer_Int16_Instance := @FExtendedEqualityComparer_Int16_VMT ; - FExtendedEqualityComparer_Int32_Instance := @FExtendedEqualityComparer_Int32_VMT ; - FExtendedEqualityComparer_Int64_Instance := @FExtendedEqualityComparer_Int64_VMT ; - FExtendedEqualityComparer_UInt8_Instance := @FExtendedEqualityComparer_UInt8_VMT ; - FExtendedEqualityComparer_UInt16_Instance := @FExtendedEqualityComparer_UInt16_VMT ; - FExtendedEqualityComparer_UInt32_Instance := @FExtendedEqualityComparer_UInt32_VMT ; - FExtendedEqualityComparer_UInt64_Instance := @FExtendedEqualityComparer_UInt64_VMT ; - FExtendedEqualityComparer_Single_Instance := @FExtendedEqualityComparer_Single_VMT ; - FExtendedEqualityComparer_Double_Instance := @FExtendedEqualityComparer_Double_VMT ; - FExtendedEqualityComparer_Extended_Instance := @FExtendedEqualityComparer_Extended_VMT ; - FExtendedEqualityComparer_Currency_Instance := @FExtendedEqualityComparer_Currency_VMT ; - FExtendedEqualityComparer_Comp_Instance := @FExtendedEqualityComparer_Comp_VMT ; - //FExtendedEqualityComparer_Binary_Instance := @FExtendedEqualityComparer_Binary_VMT ; // dynamic instance - //FExtendedEqualityComparer_DynArray_Instance := @FExtendedEqualityComparer_DynArray_VMT ; // dynamic instance - FExtendedEqualityComparer_ShortString1_Instance := @FExtendedEqualityComparer_ShortString1_VMT ; - FExtendedEqualityComparer_ShortString2_Instance := @FExtendedEqualityComparer_ShortString2_VMT ; - FExtendedEqualityComparer_ShortString3_Instance := @FExtendedEqualityComparer_ShortString3_VMT ; - FExtendedEqualityComparer_ShortString_Instance := @FExtendedEqualityComparer_ShortString_VMT ; - FExtendedEqualityComparer_AnsiString_Instance := @FExtendedEqualityComparer_AnsiString_VMT ; - FExtendedEqualityComparer_WideString_Instance := @FExtendedEqualityComparer_WideString_VMT ; - FExtendedEqualityComparer_UnicodeString_Instance := @FExtendedEqualityComparer_UnicodeString_VMT; - FExtendedEqualityComparer_Method_Instance := @FExtendedEqualityComparer_Method_VMT ; - FExtendedEqualityComparer_Variant_Instance := @FExtendedEqualityComparer_Variant_VMT ; - FExtendedEqualityComparer_Pointer_Instance := @FExtendedEqualityComparer_Pointer_VMT ; - - ////// - FExtendedEqualityComparerInstances[tkUnknown] := TInstance.CreateSelector(TMethod(TSelectMethod(TExtendedHashService.SelectBinaryEqualityComparer)).Code); - FExtendedEqualityComparerInstances[tkInteger] := TInstance.CreateSelector(TMethod(TSelectMethod(TExtendedHashService.SelectIntegerEqualityComparer)).Code); - FExtendedEqualityComparerInstances[tkChar] := TInstance.Create(False, @FExtendedEqualityComparer_UInt8_Instance); - FExtendedEqualityComparerInstances[tkEnumeration] := TInstance.CreateSelector(TMethod(TSelectMethod(TExtendedHashService.SelectIntegerEqualityComparer)).Code); - FExtendedEqualityComparerInstances[tkFloat] := TInstance.CreateSelector(TMethod(TSelectMethod(TExtendedHashService.SelectFloatEqualityComparer)).Code); - FExtendedEqualityComparerInstances[tkSet] := TInstance.CreateSelector(TMethod(TSelectMethod(TExtendedHashService.SelectBinaryEqualityComparer)).Code); - FExtendedEqualityComparerInstances[tkMethod] := TInstance.Create(False, @FExtendedEqualityComparer_Method_Instance); - FExtendedEqualityComparerInstances[tkSString] := TInstance.CreateSelector(TMethod(TSelectMethod(TExtendedHashService.SelectShortStringEqualityComparer)).Code); - FExtendedEqualityComparerInstances[tkLString] := TInstance.Create(False, @FExtendedEqualityComparer_AnsiString_Instance); - FExtendedEqualityComparerInstances[tkAString] := TInstance.Create(False, @FExtendedEqualityComparer_AnsiString_Instance); - FExtendedEqualityComparerInstances[tkWString] := TInstance.Create(False, @FExtendedEqualityComparer_WideString_Instance); - FExtendedEqualityComparerInstances[tkVariant] := TInstance.Create(False, @FExtendedEqualityComparer_Variant_Instance); - FExtendedEqualityComparerInstances[tkArray] := TInstance.CreateSelector(TMethod(TSelectMethod(TExtendedHashService.SelectBinaryEqualityComparer)).Code); - FExtendedEqualityComparerInstances[tkRecord] := TInstance.CreateSelector(TMethod(TSelectMethod(TExtendedHashService.SelectBinaryEqualityComparer)).Code); - FExtendedEqualityComparerInstances[tkInterface] := TInstance.Create(False, @FExtendedEqualityComparer_Pointer_Instance); - FExtendedEqualityComparerInstances[tkClass] := TInstance.Create(False, @FExtendedEqualityComparer_Pointer_Instance); - FExtendedEqualityComparerInstances[tkObject] := TInstance.CreateSelector(TMethod(TSelectMethod(TExtendedHashService.SelectBinaryEqualityComparer)).Code); - FExtendedEqualityComparerInstances[tkWChar] := TInstance.Create(False, @FExtendedEqualityComparer_UInt16_Instance); - FExtendedEqualityComparerInstances[tkBool] := TInstance.CreateSelector(TMethod(TSelectMethod(TExtendedHashService.SelectIntegerEqualityComparer)).Code); - FExtendedEqualityComparerInstances[tkInt64] := TInstance.Create(False, @FExtendedEqualityComparer_Int64_Instance); - FExtendedEqualityComparerInstances[tkQWord] := TInstance.Create(False, @FExtendedEqualityComparer_UInt64_Instance); - FExtendedEqualityComparerInstances[tkDynArray] := TInstance.CreateSelector(TMethod(TSelectMethod(TExtendedHashService.SelectDynArrayEqualityComparer)).Code); - FExtendedEqualityComparerInstances[tkInterfaceRaw] := TInstance.Create(False, @FExtendedEqualityComparer_Pointer_Instance); - FExtendedEqualityComparerInstances[tkProcVar] := TInstance.Create(False, @FExtendedEqualityComparer_Pointer_Instance); - FExtendedEqualityComparerInstances[tkUString] := TInstance.Create(False, @FExtendedEqualityComparer_UnicodeString_Instance); - FExtendedEqualityComparerInstances[tkUChar] := TInstance.Create(False, @FExtendedEqualityComparer_UInt16_Instance); - FExtendedEqualityComparerInstances[tkHelper] := TInstance.Create(False, @FExtendedEqualityComparer_Pointer_Instance); - FExtendedEqualityComparerInstances[tkFile] := TInstance.CreateSelector(TMethod(TSelectMethod(TExtendedHashService.SelectBinaryEqualityComparer)).Code); - FExtendedEqualityComparerInstances[tkClassRef] := TInstance.Create(False, @FExtendedEqualityComparer_Pointer_Instance); - FExtendedEqualityComparerInstances[tkPointer] := TInstance.Create(False, @FExtendedEqualityComparer_Pointer_Instance); -end; - -{ TEqualityComparer } - -class function TEqualityComparer.Default: IEqualityComparer; -begin - Result := _LookupVtableInfo(giEqualityComparer, TypeInfo(T), SizeOf(T)); -end; - -class function TEqualityComparer.Default(AHashFactoryClass: THashFactoryClass): IEqualityComparer; -begin - if AHashFactoryClass.InheritsFrom(TExtendedHashFactory) then - Result := _LookupVtableInfoEx(giExtendedEqualityComparer, TypeInfo(T), SizeOf(T), AHashFactoryClass) - else if AHashFactoryClass.InheritsFrom(THashFactory) then - Result := _LookupVtableInfoEx(giEqualityComparer, TypeInfo(T), SizeOf(T), AHashFactoryClass); -end; - -class function TEqualityComparer.Construct(const AEqualityComparison: TOnEqualityComparison; - const AHasher: TOnHasher): IEqualityComparer; -begin - Result := TDelegatedEqualityComparerEvents.Create(AEqualityComparison, AHasher); -end; - -class function TEqualityComparer.Construct(const AEqualityComparison: TEqualityComparisonFunc; - const AHasher: THasherFunc): IEqualityComparer; -begin - Result := TDelegatedEqualityComparerFunc.Create(AEqualityComparison, AHasher); -end; - -{ TDelegatedEqualityComparerEvents } - -function TDelegatedEqualityComparerEvents.Equals(constref ALeft, ARight: T): Boolean; -begin - Result := FEqualityComparison(ALeft, ARight); -end; - -function TDelegatedEqualityComparerEvents.GetHashCode(constref AValue: T): UInt32; -begin - Result := FHasher(AValue); -end; - -constructor TDelegatedEqualityComparerEvents.Create(const AEqualityComparison: TOnEqualityComparison; - const AHasher: TOnHasher); -begin - FEqualityComparison := AEqualityComparison; - FHasher := AHasher; -end; - -{ TDelegatedEqualityComparerFunc } - -function TDelegatedEqualityComparerFunc.Equals(constref ALeft, ARight: T): Boolean; -begin - Result := FEqualityComparison(ALeft, ARight); -end; - -function TDelegatedEqualityComparerFunc.GetHashCode(constref AValue: T): UInt32; -begin - Result := FHasher(AValue); -end; - -constructor TDelegatedEqualityComparerFunc.Create(const AEqualityComparison: TEqualityComparisonFunc; - const AHasher: THasherFunc); -begin - FEqualityComparison := AEqualityComparison; - FHasher := AHasher; -end; - -{ TDelegatedExtendedEqualityComparerEvents } - -function TDelegatedExtendedEqualityComparerEvents.GetHashCodeMethod(constref AValue: T): UInt32; -var - LHashList: array[0..1] of Int32; - LHashListParams: array[0..3] of Int16 absolute LHashList; -begin - LHashListParams[0] := -1; - FExtendedHasher(AValue, @LHashList[0]); - Result := LHashList[1]; -end; - -function TDelegatedExtendedEqualityComparerEvents.Equals(constref ALeft, ARight: T): Boolean; -begin - Result := FEqualityComparison(ALeft, ARight); -end; - -function TDelegatedExtendedEqualityComparerEvents.GetHashCode(constref AValue: T): UInt32; -begin - Result := FHasher(AValue); -end; - -procedure TDelegatedExtendedEqualityComparerEvents.GetHashList(constref AValue: T; AHashList: PUInt32); -begin - FExtendedHasher(AValue, AHashList); -end; - -constructor TDelegatedExtendedEqualityComparerEvents.Create(const AEqualityComparison: TOnEqualityComparison; - const AHasher: TOnHasher; const AExtendedHasher: TOnExtendedHasher); -begin - FEqualityComparison := AEqualityComparison; - FHasher := AHasher; - FExtendedHasher := AExtendedHasher; -end; - -constructor TDelegatedExtendedEqualityComparerEvents.Create(const AEqualityComparison: TOnEqualityComparison; - const AExtendedHasher: TOnExtendedHasher); -begin - Create(AEqualityComparison, GetHashCodeMethod, AExtendedHasher); -end; - -{ TDelegatedExtendedEqualityComparerFunc } - -function TDelegatedExtendedEqualityComparerFunc.Equals(constref ALeft, ARight: T): Boolean; -begin - Result := FEqualityComparison(ALeft, ARight); -end; - -function TDelegatedExtendedEqualityComparerFunc.GetHashCode(constref AValue: T): UInt32; -var - LHashList: array[0..1] of Int32; - LHashListParams: array[0..3] of Int16 absolute LHashList; -begin - if not Assigned(FHasher) then - begin - LHashListParams[0] := -1; - FExtendedHasher(AValue, @LHashList[0]); - Result := LHashList[1]; - end - else - Result := FHasher(AValue); -end; - -procedure TDelegatedExtendedEqualityComparerFunc.GetHashList(constref AValue: T; AHashList: PUInt32); -begin - FExtendedHasher(AValue, AHashList); -end; - -constructor TDelegatedExtendedEqualityComparerFunc.Create(const AEqualityComparison: TEqualityComparisonFunc; - const AHasher: THasherFunc; const AExtendedHasher: TExtendedHasherFunc); -begin - FEqualityComparison := AEqualityComparison; - FHasher := AHasher; - FExtendedHasher := AExtendedHasher; -end; - -constructor TDelegatedExtendedEqualityComparerFunc.Create(const AEqualityComparison: TEqualityComparisonFunc; - const AExtendedHasher: TExtendedHasherFunc); -begin - Create(AEqualityComparison, nil, AExtendedHasher); -end; - -{ TExtendedEqualityComparer } - -class function TExtendedEqualityComparer.Default: IExtendedEqualityComparer; -begin - Result := _LookupVtableInfo(giExtendedEqualityComparer, TypeInfo(T), SizeOf(T)); -end; - -class function TExtendedEqualityComparer.Default( - AExtenedHashFactoryClass: TExtendedHashFactoryClass - ): IExtendedEqualityComparer; -begin - Result := _LookupVtableInfoEx(giExtendedEqualityComparer, TypeInfo(T), SizeOf(T), AExtenedHashFactoryClass); -end; - -class function TExtendedEqualityComparer.Construct( - const AEqualityComparison: TOnEqualityComparison; const AHasher: TOnHasher; - const AExtendedHasher: TOnExtendedHasher): IExtendedEqualityComparer; -begin - Result := TDelegatedExtendedEqualityComparerEvents.Create(AEqualityComparison, AHasher, AExtendedHasher); -end; - -class function TExtendedEqualityComparer.Construct( - const AEqualityComparison: TEqualityComparisonFunc; const AHasher: THasherFunc; - const AExtendedHasher: TExtendedHasherFunc): IExtendedEqualityComparer; -begin - Result := TDelegatedExtendedEqualityComparerFunc.Create(AEqualityComparison, AHasher, AExtendedHasher); -end; - -class function TExtendedEqualityComparer.Construct( - const AEqualityComparison: TOnEqualityComparison; - const AExtendedHasher: TOnExtendedHasher): IExtendedEqualityComparer; -begin - Result := TDelegatedExtendedEqualityComparerEvents.Create(AEqualityComparison, AExtendedHasher); -end; - -class function TExtendedEqualityComparer.Construct( - const AEqualityComparison: TEqualityComparisonFunc; - const AExtendedHasher: TExtendedHasherFunc): IExtendedEqualityComparer; -begin - Result := TDelegatedExtendedEqualityComparerFunc.Create(AEqualityComparison, AExtendedHasher); -end; - -{ TDelphiHashFactory } - -class function TDelphiHashFactory.GetHashService: THashServiceClass; -begin - Result := THashService; -end; - -class function TDelphiHashFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32): UInt32; -begin - Result := DelphiHashLittle(AKey, ASize, AInitVal); -end; - -{ TGenericsHashFactory } - -class function TGenericsHashFactory.GetHashService: THashServiceClass; -begin - Result := THashService; -end; - -class function TGenericsHashFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32): UInt32; -begin - Result := mORMotHasher(AInitVal, AKey, ASize); -end; - -{ TxxHash32HashFactory } - -class function TxxHash32HashFactory.GetHashService: THashServiceClass; -begin - Result := THashService; -end; - -class function TxxHash32HashFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; - AInitVal: UInt32): UInt32; -begin - Result := xxHash32(AInitVal, AKey, ASize); -end; - -{ TxxHash32PascalHashFactory } - -class function TxxHash32PascalHashFactory.GetHashService: THashServiceClass; -begin - Result := THashService; -end; - -class function TxxHash32PascalHashFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; - AInitVal: UInt32): UInt32; -begin - Result := xxHash32Pascal(AInitVal, AKey, ASize); -end; - -{ TAdler32HashFactory } - -class function TAdler32HashFactory.GetHashService: THashServiceClass; -begin - Result := THashService; -end; - -class function TAdler32HashFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; - AInitVal: UInt32): UInt32; -begin - Result := Adler32(AKey, ASize); -end; - -{ TSdbmHashFactory } - -class function TSdbmHashFactory.GetHashService: THashServiceClass; -begin - Result := THashService; -end; - -class function TSdbmHashFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; - AInitVal: UInt32): UInt32; -begin - Result := sdbm(AKey, ASize); -end; - -{ TSimpleChecksumFactory } - -class function TSimpleChecksumFactory.GetHashService: THashServiceClass; -begin - Result := THashService; -end; - -class function TSimpleChecksumFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; - AInitVal: UInt32): UInt32; -begin - Result := SimpleChecksumHash(AKey, ASize); -end; - -{ TDelphiDoubleHashFactory } - -class function TDelphiDoubleHashFactory.GetHashService: THashServiceClass; -begin - Result := TExtendedHashService; -end; - -class function TDelphiDoubleHashFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32): UInt32; -begin - Result := DelphiHashLittle(AKey, ASize, AInitVal); -end; - -class procedure TDelphiDoubleHashFactory.GetHashList(AKey: Pointer; ASize: SizeInt; AHashList: PUInt32; - AOptions: TGetHashListOptions); -var - LHash: UInt32; - AHashListParams: PUInt16 absolute AHashList; -begin -{$WARNINGS OFF} - case AHashListParams[0] of - -2: - begin - if not (ghloHashListAsInitData in AOptions) then - AHashList[1] := 0; - LHash := 0; - DelphiHashLittle2(AKey, ASize, LHash, AHashList[1]); - Exit; - end; - -1: - begin - if not (ghloHashListAsInitData in AOptions) then - AHashList[1] := 0; - LHash := 0; - DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); - Exit; - end; - 0: Exit; - 1: - begin - if not (ghloHashListAsInitData in AOptions) then - AHashList[1] := 0; - LHash := 0; - DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); - Exit; - end; - 2: - begin - if not (ghloHashListAsInitData in AOptions) then - begin - AHashList[1] := 0; - AHashList[2] := 0; - end; - DelphiHashLittle2(AKey, ASize, AHashList[1], AHashList[2]); - Exit; - end; - else - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - end; -{.$WARNINGS ON} // do not enable warnings ever in this unit, or you will get many warnings about uninitialized TEqualityComparerVMT fields -end; - -{ TDelphiQuadrupleHashFactory } - -class function TDelphiQuadrupleHashFactory.GetHashService: THashServiceClass; -begin - Result := TExtendedHashService; -end; - -class function TDelphiQuadrupleHashFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32): UInt32; -begin - Result := DelphiHashLittle(AKey, ASize, AInitVal); -end; - -class procedure TDelphiQuadrupleHashFactory.GetHashList(AKey: Pointer; ASize: SizeInt; AHashList: PUInt32; - AOptions: TGetHashListOptions); -var - LHash: UInt32; - AHashListParams: PInt16 absolute AHashList; -begin - case AHashListParams[0] of - -4: - begin - if not (ghloHashListAsInitData in AOptions) then - AHashList[1] := 1988; - LHash := 2004; - DelphiHashLittle2(AKey, ASize, LHash, AHashList[1]); - Exit; - end; - -3: - begin - if not (ghloHashListAsInitData in AOptions) then - AHashList[1] := 2004; - LHash := 1988; - DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); - Exit; - end; - -2: - begin - if not (ghloHashListAsInitData in AOptions) then - AHashList[1] := 0; - LHash := 0; - DelphiHashLittle2(AKey, ASize, LHash, AHashList[1]); - Exit; - end; - -1: - begin - if not (ghloHashListAsInitData in AOptions) then - AHashList[1] := 0; - LHash := 0; - DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); - Exit; - end; - 0: Exit; - 1: - begin - if not (ghloHashListAsInitData in AOptions) then - AHashList[1] := 0; - LHash := 0; - DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); - Exit; - end; - 2: - begin - case AHashListParams[1] of - 0, 1: - begin - if not (ghloHashListAsInitData in AOptions) then - begin - AHashList[1] := 0; - AHashList[2] := 0; - end; - DelphiHashLittle2(AKey, ASize, AHashList[1], AHashList[2]); - Exit; - end; - 2: - begin - if not (ghloHashListAsInitData in AOptions) then - begin - AHashList[1] := 2004; - AHashList[2] := 1988; - end; - DelphiHashLittle2(AKey, ASize, AHashList[1], AHashList[2]); - Exit; - end; - else - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - end; - end; - 4: - case AHashListParams[1] of - 1: - begin - if not (ghloHashListAsInitData in AOptions) then - begin - AHashList[1] := 0; - AHashList[2] := 0; - end; - DelphiHashLittle2(AKey, ASize, AHashList[1], AHashList[2]); - Exit; - end; - 2: - begin - if not (ghloHashListAsInitData in AOptions) then - begin - AHashList[3] := 2004; - AHashList[4] := 1988; - end; - DelphiHashLittle2(AKey, ASize, AHashList[3], AHashList[4]); - Exit; - end; - else - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - end; - else - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - end; -end; - -{ TDelphiSixfoldHashFactory } - -class function TDelphiSixfoldHashFactory.GetHashService: THashServiceClass; -begin - Result := TExtendedHashService; -end; - -class function TDelphiSixfoldHashFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32): UInt32; -begin - Result := DelphiHashLittle(AKey, ASize, AInitVal); -end; - -class procedure TDelphiSixfoldHashFactory.GetHashList(AKey: Pointer; ASize: SizeInt; AHashList: PUInt32; - AOptions: TGetHashListOptions); -var - LHash: UInt32; - AHashListParams: PInt16 absolute AHashList; -begin - case AHashListParams[0] of - -6: - begin - if not (ghloHashListAsInitData in AOptions) then - AHashList[1] := 2; - LHash := 1; - DelphiHashLittle2(AKey, ASize, LHash, AHashList[1]); - Exit; - end; - -5: - begin - if not (ghloHashListAsInitData in AOptions) then - AHashList[1] := 1; - LHash := 2; - DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); - Exit; - end; - -4: - begin - if not (ghloHashListAsInitData in AOptions) then - AHashList[1] := 1988; - LHash := 2004; - DelphiHashLittle2(AKey, ASize, LHash, AHashList[1]); - Exit; - end; - -3: - begin - if not (ghloHashListAsInitData in AOptions) then - AHashList[1] := 2004; - LHash := 1988; - DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); - Exit; - end; - -2: - begin - if not (ghloHashListAsInitData in AOptions) then - AHashList[1] := 0; - LHash := 0; - DelphiHashLittle2(AKey, ASize, LHash, AHashList[1]); - Exit; - end; - -1: - begin - if not (ghloHashListAsInitData in AOptions) then - AHashList[1] := 0; - LHash := 0; - DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); - Exit; - end; - 0: Exit; - 1: - begin - if not (ghloHashListAsInitData in AOptions) then - AHashList[1] := 0; - LHash := 0; - DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); - Exit; - end; - 2: - begin - case AHashListParams[1] of - 0, 1: - begin - if not (ghloHashListAsInitData in AOptions) then - begin - AHashList[1] := 0; - AHashList[2] := 0; - end; - DelphiHashLittle2(AKey, ASize, AHashList[1], AHashList[2]); - Exit; - end; - 2: - begin - if not (ghloHashListAsInitData in AOptions) then - begin - AHashList[1] := 2004; - AHashList[2] := 1988; - end; - DelphiHashLittle2(AKey, ASize, AHashList[1], AHashList[2]); - Exit; - end; - else - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - end; - end; - 6: - case AHashListParams[1] of - 1: - begin - if not (ghloHashListAsInitData in AOptions) then - begin - AHashList[1] := 0; - AHashList[2] := 0; - end; - DelphiHashLittle2(AKey, ASize, AHashList[1], AHashList[2]); - Exit; - end; - 2: - begin - if not (ghloHashListAsInitData in AOptions) then - begin - AHashList[3] := 2004; - AHashList[4] := 1988; - end; - DelphiHashLittle2(AKey, ASize, AHashList[3], AHashList[4]); - Exit; - end; - 3: - begin - if not (ghloHashListAsInitData in AOptions) then - begin - AHashList[5] := 1; - AHashList[6] := 2; - end; - DelphiHashLittle2(AKey, ASize, AHashList[5], AHashList[6]); - Exit; - end; - else - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - end; - else - raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); - end; -end; - -{ TOrdinalComparer } - -class constructor TOrdinalComparer.Create; -begin - if THashFactory.InheritsFrom(TExtendedHashService) then - begin - FExtendedEqualityComparer := TExtendedEqualityComparer.Default(TExtendedHashFactoryClass(THashFactory)); - FEqualityComparer := IEqualityComparer(FExtendedEqualityComparer); - end - else - FEqualityComparer := TEqualityComparer.Default(THashFactory); - FComparer := TComparer.Default; -end; - -{ TGStringComparer } - -class destructor TGStringComparer.Destroy; -begin - if Assigned(FOrdinal) then - FOrdinal.Free; -end; - -class function TGStringComparer.Ordinal: TCustomComparer; -begin - if not Assigned(FOrdinal) then - FOrdinal := TGOrdinalStringComparer.Create; - Result := FOrdinal; -end; - -{ TGOrdinalStringComparer } - -function TGOrdinalStringComparer.Compare(constref ALeft, ARight: T): Integer; -begin - Result := FComparer.Compare(ALeft, ARight); -end; - -function TGOrdinalStringComparer.Equals(constref ALeft, ARight: T): Boolean; -begin - Result := FEqualityComparer.Equals(ALeft, ARight); -end; - -function TGOrdinalStringComparer.GetHashCode(constref AValue: T): UInt32; -begin - Result := FEqualityComparer.GetHashCode(AValue); -end; - -procedure TGOrdinalStringComparer.GetHashList(constref AValue: T; AHashList: PUInt32); -begin - FExtendedEqualityComparer.GetHashList(AValue, AHashList); -end; - -{ TGIStringComparer } - -class destructor TGIStringComparer.Destroy; -begin - if Assigned(FOrdinal) then - FOrdinal.Free; -end; - -class function TGIStringComparer.Ordinal: TCustomComparer; -begin - if not Assigned(FOrdinal) then - FOrdinal := TGOrdinalIStringComparer.Create; - Result := FOrdinal; -end; - -{ TGOrdinalIStringComparer } - -function TGOrdinalIStringComparer.Compare(constref ALeft, ARight: T): Integer; -begin - Result := FComparer.Compare(ALeft.ToLower, ARight.ToLower); -end; - -function TGOrdinalIStringComparer.Equals(constref ALeft, ARight: T): Boolean; -begin - Result := FEqualityComparer.Equals(ALeft.ToLower, ARight.ToLower); -end; - -function TGOrdinalIStringComparer.GetHashCode(constref AValue: T): UInt32; -begin - Result := FEqualityComparer.GetHashCode(AValue.ToLower); -end; - -procedure TGOrdinalIStringComparer.GetHashList(constref AValue: T; AHashList: PUInt32); -begin - FExtendedEqualityComparer.GetHashList(AValue.ToLower, AHashList); -end; - -function BobJenkinsHash(const AData; ALength, AInitData: Integer): Integer; -begin - Result := DelphiHashLittle(@AData, ALength, AInitData); -end; - -function BinaryCompare(const ALeft, ARight: Pointer; ASize: PtrUInt): Integer; -begin - Result := CompareMemRange(ALeft, ARight, ASize); -end; - -function _LookupVtableInfo(AGInterface: TDefaultGenericInterface; ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; -begin - Result := _LookupVtableInfoEx(AGInterface, ATypeInfo, ASize, nil); -end; - -function _LookupVtableInfoEx(AGInterface: TDefaultGenericInterface; ATypeInfo: PTypeInfo; ASize: SizeInt; - AFactory: THashFactoryClass): Pointer; -begin - case AGInterface of - giComparer: - Exit( - TComparerService.LookupComparer(ATypeInfo, ASize)); - giEqualityComparer: - begin - if AFactory = nil then - AFactory := TDefaultHashFactory; - - Exit( - AFactory.GetHashService.LookupEqualityComparer(ATypeInfo, ASize)); - end; - giExtendedEqualityComparer: - begin - if AFactory = nil then - AFactory := TDelphiDoubleHashFactory; - - Exit( - TExtendedHashServiceClass(AFactory.GetHashService).LookupExtendedEqualityComparer(ATypeInfo, ASize)); - end; - else - System.Error(reRangeError); - Exit(nil); - end; -end; - -end. - diff --git a/components/sparta/generics/source/sparta_generics.hashes.pas b/components/sparta/generics/source/sparta_generics.hashes.pas deleted file mode 100644 index e1c186790f..0000000000 --- a/components/sparta/generics/source/sparta_generics.hashes.pas +++ /dev/null @@ -1,1617 +0,0 @@ -{ - This file is part of the Free Pascal/NewPascal run time library. - Copyright (c) 2014 by Maciej Izak (hnb) - member of the NewPascal development team (http://newpascal.org) - - Copyright(c) 2004-2018 DaThoX - - It contains the generics collections 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. - - Acknowledgment - - Thanks to Sphere 10 Software (http://sphere10.com) for sponsoring - many new types and major refactoring of entire library. - - Thanks to mORMot (http://synopse.info) project for the best implementations - of hashing functions like crc32c and xxHash32 :) - - **********************************************************************} - -unit sparta_Generics.Hashes; - -{$MODE DELPHI}{$H+} -{$POINTERMATH ON} -{$MACRO ON} -{$COPERATORS ON} -{$OVERFLOWCHECKS OFF} -{$RANGECHECKS OFF} - -interface - -uses - Classes, SysUtils; - -{ Warning: the following set of macro code - that decides to use assembler or normal code - needs to stay after the _INTERFACE keyword - because FPC_PIC macro is only set after this keyword, - as it can be modified before by the global $PIC preprocessor directive. - Pierre Muller 2018/07/04 } - -{$ifdef FPC_PIC} - {$define DISABLE_X86_CPUINTEL} -{$endif FPC_PIC} - -{$if defined(OPENBSD) or defined(EMX) or defined(OS2)} - { These targets have old GNU assemblers that } - { do not support all instructions used in assembler code below } - {$define DISABLE_X86_CPUINTEL} -{$endif} - -{$ifdef CPU64} - {$define PUREPASCAL} - {$ifdef CPUX64} - {$define CPUINTEL} - {$ASMMODE INTEL} - {$endif CPUX64} -{$else} - {$ifdef CPUX86} - {$ifndef DISABLE_X86_CPUINTEL} - {$define CPUINTEL} - {$ASMMODE INTEL} - {$else} - { Assembler code uses references to static - variables with are not PIC ready } - {$define PUREPASCAL} - {$endif} - {$else CPUX86} - {$define PUREPASCAL} - {$endif} -{$endif CPU64} - -// 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; -function xxHash32(crc: cardinal; P: Pointer; len: integer): cardinal;{$IFNDEF CPUINTEL}inline;{$ENDIF} -// pure pascal implementation of xxHash32 -function xxHash32Pascal(crc: cardinal; P: Pointer; len: integer): cardinal; - -type - THasher = function(crc: cardinal; buf: Pointer; len: cardinal): cardinal; - -var - crc32c: THasher; - mORMotHasher: THasher; - -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; - -{$ifdef CPUARM} // circumvent FPC issue on ARM -function ToByte(value: cardinal): cardinal; inline; -begin - result := value and $ff; -end; -{$else} -type ToByte = byte; -{$endif} - -{$ifdef CPUINTEL} // use optimized x86/x64 asm versions for xxHash32 - -{$ifdef CPUX86} -function xxHash32(crc: cardinal; P: Pointer; len: integer): cardinal; -asm - xchg edx, ecx - push ebp - push edi - lea ebp, [ecx+edx] - push esi - push ebx - sub esp, 8 - cmp edx, 15 - mov ebx, eax - mov dword ptr [esp], edx - lea eax, [ebx+165667B1H] - jbe @2 - lea eax, [ebp-10H] - lea edi, [ebx+24234428H] - lea esi, [ebx-7A143589H] - mov dword ptr [esp+4H], ebp - mov edx, eax - lea eax, [ebx+61C8864FH] - mov ebp, edx -@1: mov edx, dword ptr [ecx] - imul edx, edx, -2048144777 - add edi, edx - rol edi, 13 - imul edi, edi, -1640531535 - mov edx, dword ptr [ecx+4] - imul edx, edx, -2048144777 - add esi, edx - rol esi, 13 - imul esi, esi, -1640531535 - mov edx, dword ptr [ecx+8] - imul edx, edx, -2048144777 - add ebx, edx - rol ebx, 13 - imul ebx, ebx, -1640531535 - mov edx, dword ptr [ecx+12] - lea ecx, [ecx+16] - imul edx, edx, -2048144777 - add eax, edx - rol eax, 13 - imul eax, eax, -1640531535 - cmp ebp, ecx - jnc @1 - rol edi, 1 - rol esi, 7 - rol ebx, 12 - add esi, edi - mov ebp, dword ptr [esp+4H] - ror eax, 14 - add ebx, esi - add eax, ebx -@2: lea esi, [ecx+4H] - add eax, dword ptr [esp] - cmp ebp, esi - jc @4 - mov ebx, esi - nop -@3: imul edx, dword ptr [ebx-4H], -1028477379 - add ebx, 4 - add eax, edx - ror eax, 15 - imul eax, eax, 668265263 - cmp ebp, ebx - jnc @3 - lea edx, [ebp-4H] - sub edx, ecx - mov ecx, edx - and ecx, 0FFFFFFFCH - add ecx, esi -@4: cmp ebp, ecx - jbe @6 -@5: movzx edx, byte ptr [ecx] - add ecx, 1 - imul edx, edx, 374761393 - add eax, edx - rol eax, 11 - imul eax, eax, -1640531535 - cmp ebp, ecx - jnz @5 - nop -@6: mov edx, eax - add esp, 8 - shr edx, 15 - xor eax, edx - imul eax, eax, -2048144777 - pop ebx - pop esi - mov edx, eax - shr edx, 13 - xor eax, edx - imul eax, eax, -1028477379 - pop edi - pop ebp - mov edx, eax - shr edx, 16 - xor eax, edx -end; -{$endif CPUX86} - -{$ifdef CPUX64} -function xxHash32(crc: cardinal; P: Pointer; len: integer): cardinal; -asm - {$ifndef WIN64} // crc=rdi P=rsi len=rdx - mov r8, rdi - mov rcx, rsi - {$else} // crc=r8 P=rcx len=rdx - mov r10, r8 - mov r8, rcx - mov rcx, rdx - mov rdx, r10 - push rsi // Win64 expects those registers to be preserved - push rdi - {$endif} - // P=r8 len=rcx crc=rdx - push rbx - lea r10, [rcx+rdx] - cmp rdx, 15 - lea eax, [r8+165667B1H] - jbe @2 - lea rsi, [r10-10H] - lea ebx, [r8+24234428H] - lea edi, [r8-7A143589H] - lea eax, [r8+61C8864FH] -@1: imul r9d, dword ptr [rcx], -2048144777 - add rcx, 16 - imul r11d, dword ptr [rcx-0CH], -2048144777 - add ebx, r9d - lea r9d, [r11+rdi] - rol ebx, 13 - rol r9d, 13 - imul ebx, ebx, -1640531535 - imul edi, r9d, -1640531535 - imul r9d, dword ptr [rcx-8H], -2048144777 - add r8d, r9d - imul r9d, dword ptr [rcx-4H], -2048144777 - rol r8d, 13 - imul r8d, r8d, -1640531535 - add eax, r9d - rol eax, 13 - imul eax, eax, -1640531535 - cmp rsi, rcx - jnc @1 - rol edi, 7 - rol ebx, 1 - rol r8d, 12 - mov r9d, edi - ror eax, 14 - add r9d, ebx - add r8d, r9d - add eax, r8d -@2: lea r9, [rcx+4H] - add eax, edx - cmp r10, r9 - jc @4 - mov r8, r9 -@3: imul edx, dword ptr [r8-4H], -1028477379 - add r8, 4 - add eax, edx - ror eax, 15 - imul eax, eax, 668265263 - cmp r10, r8 - jnc @3 - lea rdx, [r10-4H] - sub rdx, rcx - mov rcx, rdx - and rcx, 0FFFFFFFFFFFFFFFCH - add rcx, r9 -@4: cmp r10, rcx - jbe @6 -@5: movzx edx, byte ptr [rcx] - add rcx, 1 - imul edx, edx, 374761393 - add eax, edx - rol eax, 11 - imul eax, eax, -1640531535 - cmp r10, rcx - jnz @5 -@6: mov edx, eax - shr edx, 15 - xor eax, edx - imul eax, eax, -2048144777 - mov edx, eax - shr edx, 13 - xor eax, edx - imul eax, eax, -1028477379 - mov edx, eax - shr edx, 16 - xor eax, edx - pop rbx - {$ifdef WIN64} - pop rdi - pop rsi - {$endif} -end; -{$endif CPUX64} -{$else not CPUINTEL} -function xxHash32(crc: cardinal; P: Pointer; len: integer): cardinal; -begin - result := xxHash32Pascal(crc, P, len); -end; -{$endif CPUINTEL} - -const - PRIME32_1 = 2654435761; - PRIME32_2 = 2246822519; - PRIME32_3 = 3266489917; - PRIME32_4 = 668265263; - PRIME32_5 = 374761393; - -// RolDWord is an intrinsic function under FPC :) -function Rol13(value: cardinal): cardinal; inline; -begin - result := RolDWord(value, 13); -end; - -function xxHash32Pascal(crc: cardinal; P: Pointer; len: integer): cardinal; -var c1, c2, c3, c4: cardinal; - PLimit, PEnd: PAnsiChar; -begin - PEnd := P + len; - if len >= 16 then begin - PLimit := PEnd - 16; - c3 := crc; - c2 := c3 + PRIME32_2; - c1 := c2 + PRIME32_1; - c4 := c3 - PRIME32_1; - repeat - c1 := PRIME32_1 * Rol13(c1 + PRIME32_2 * PCardinal(P)^); - c2 := PRIME32_1 * Rol13(c2 + PRIME32_2 * PCardinal(P+4)^); - c3 := PRIME32_1 * Rol13(c3 + PRIME32_2 * PCardinal(P+8)^); - c4 := PRIME32_1 * Rol13(c4 + PRIME32_2 * PCardinal(P+12)^); - inc(P, 16); - until not (P <= PLimit); - result := RolDWord(c1, 1) + RolDWord(c2, 7) + RolDWord(c3, 12) + RolDWord(c4, 18); - end else - result := crc + PRIME32_5; - inc(result, len); - { Use "P + 4 <= PEnd" instead of "P <= PEnd - 4" to avoid crashes in case P = nil. - When P = nil, - then "PtrUInt(PEnd - 4)" is 4294967292, - so the condition "P <= PEnd - 4" would be satisfied, - and the code would try to access PCardinal(nil)^ causing a SEGFAULT. } - while P + 4 <= PEnd do begin - inc(result, PCardinal(P)^ * PRIME32_3); - result := RolDWord(result, 17) * PRIME32_4; - inc(P, 4); - end; - while P < PEnd do begin - inc(result, PByte(P)^ * PRIME32_5); - result := RolDWord(result, 11) * PRIME32_1; - inc(P); - end; - result := result xor (result shr 15); - result := result * PRIME32_2; - result := result xor (result shr 13); - result := result * PRIME32_3; - result := result xor (result shr 16); -end; - -{$ifdef CPUINTEL} - -type - TRegisters = record - eax,ebx,ecx,edx: cardinal; - end; - -{$ifdef CPU64} -procedure GetCPUID(Param: Cardinal; var Registers: TRegisters); nostackframe; assembler; -asm - {$ifdef win64} - mov eax, ecx - mov r9, rdx - {$else} - mov eax, edi - mov r9, rsi - {$endif win64} - mov r10, rbx // preserve rbx - xor ebx, ebx - xor ecx, ecx - xor edx, edx - cpuid - mov TRegisters(r9).&eax, eax - mov TRegisters(r9).&ebx, ebx - mov TRegisters(r9).&ecx, ecx - mov TRegisters(r9).&edx, edx - mov rbx, r10 -end; - -function crc32csse42(crc: cardinal; buf: Pointer; len: cardinal): cardinal; nostackframe; assembler; -asm // ecx=crc, rdx=buf, r8=len (Linux: edi,rsi,rdx) - {$ifdef win64} - mov eax, ecx - {$else} - mov eax, edi - mov r8, rdx - mov rdx, rsi - {$endif win64} - not eax - test rdx, rdx - jz @0 - test r8, r8 - jz @0 -@7: test dl, 7 - jz @8 // align to 8 bytes boundary - crc32 eax, byte ptr[rdx] - inc rdx - dec r8 - jz @0 - test dl, 7 - jnz @7 -@8: mov rcx, r8 - shr r8, 3 - jz @2 -@1: - crc32 rax, qword [rdx] // hash 8 bytes per loop - dec r8 - lea rdx, [rdx + 8] - jnz @1 -@2: and ecx, 7 - jz @0 - cmp ecx, 4 - jb @4 - crc32 eax, dword ptr[rdx] - sub ecx, 4 - lea rdx, [rdx + 4] - jz @0 -@4: crc32 eax, byte ptr[rdx] - dec ecx - jz @0 - crc32 eax, byte ptr[rdx + 1] - dec ecx - jz @0 - crc32 eax, byte ptr[rdx + 2] -@0: not eax -end; -{$endif CPU64} - -{$ifdef CPUX86} -procedure GetCPUID(Param: Cardinal; var Registers: TRegisters); -asm - push esi - push edi - mov esi, edx - mov edi, eax - pushfd - pop eax - mov edx, eax - xor eax, $200000 - push eax - popfd - pushfd - pop eax - xor eax, edx - jz @nocpuid - push ebx - mov eax, edi - xor ecx, ecx - cpuid - mov TRegisters(esi).&eax, eax - mov TRegisters(esi).&ebx, ebx - mov TRegisters(esi).&ecx, ecx - mov TRegisters(esi).&edx, edx - pop ebx -@nocpuid: - pop edi - pop esi -end; - -function crc32csse42(crc: cardinal; buf: Pointer; len: cardinal): cardinal; -asm // eax=crc, edx=buf, ecx=len - not eax - test ecx, ecx - jz @0 - test edx, edx - jz @0 -@3: test edx, 3 - jz @8 // align to 4 bytes boundary - crc32 eax, byte ptr[edx] - inc edx - dec ecx - jz @0 - test edx, 3 - jnz @3 -@8: push ecx - shr ecx, 3 - jz @2 -@1: - crc32 eax, dword ptr[edx] - crc32 eax, dword ptr[edx + 4] - dec ecx - lea edx, [edx + 8] - jnz @1 -@2: pop ecx - and ecx, 7 - jz @0 - cmp ecx, 4 - jb @4 - crc32 eax, dword ptr[edx] - sub ecx, 4 - lea edx, [edx + 4] - jz @0 -@4: - crc32 eax, byte ptr[edx] - dec ecx - jz @0 - crc32 eax, byte ptr[edx + 1] - dec ecx - jz @0 - crc32 eax, byte ptr[edx + 2] -@0: not eax -end; -{$endif CPUX86} - -type - /// the potential features, retrieved from an Intel CPU - // - see https://en.wikipedia.org/wiki/CPUID#EAX.3D1:_Processor_Info_and_Feature_Bits - TIntelCpuFeature = - ( { in EDX } - cfFPU, cfVME, cfDE, cfPSE, cfTSC, cfMSR, cfPAE, cfMCE, - cfCX8, cfAPIC, cf_d10, cfSEP, cfMTRR, cfPGE, cfMCA, cfCMOV, - cfPAT, cfPSE36, cfPSN, cfCLFSH, cf_d20, cfDS, cfACPI, cfMMX, - cfFXSR, cfSSE, cfSSE2, cfSS, cfHTT, cfTM, cfIA64, cfPBE, - { in ECX } - cfSSE3, cfCLMUL, cfDS64, cfMON, cfDSCPL, cfVMX, cfSMX, cfEST, - cfTM2, cfSSSE3, cfCID, cfSDBG, cfFMA, cfCX16, cfXTPR, cfPDCM, - cf_c16, cfPCID, cfDCA, cfSSE41, cfSSE42, cfX2A, cfMOVBE, cfPOPCNT, - cfTSC2, cfAESNI, cfXS, cfOSXS, cfAVX, cfF16C, cfRAND, cfHYP, - { extended features in EBX, ECX } - cfFSGS, cf_b01, cfSGX, cfBMI1, cfHLE, cfAVX2, cf_b06, cfSMEP, - cfBMI2, cfERMS, cfINVPCID, cfRTM, cfPQM, cf_b13, cfMPX, cfPQE, - cfAVX512F, cfAVX512DQ, cfRDSEED, cfADX, cfSMAP, cfAVX512IFMA, cfPCOMMIT, cfCLFLUSH, - cfCLWB, cfIPT, cfAVX512PF, cfAVX512ER, cfAVX512CD, cfSHA, cfAVX512BW, cfAVX512VL, - cfPREFW1, cfAVX512VBMI, cfUMIP, cfPKU, cfOSPKE, cf_c05, cf_c06, cf_c07, - cf_c08, cf_c09, cf_c10, cf_c11, cf_c12, cf_c13, cfAVX512VPC, cf_c15, - cf_cc16, cf_c17, cf_c18, cf_c19, cf_c20, cf_c21, cfRDPID, cf_c23, - cf_c24, cf_c25, cf_c26, cf_c27, cf_c28, cf_c29, cfSGXLC, cf_c31, - cf_d0, cf_d1, cfAVX512NNI, cfAVX512MAS, cf_d4, cf_d5, cf_d6, cf_d7); - - /// all features, as retrieved from an Intel CPU - TIntelCpuFeatures = set of TIntelCpuFeature; - -var - /// the available CPU features, as recognized at program startup - CpuFeatures: TIntelCpuFeatures; - -procedure TestIntelCpuFeatures; -var regs: TRegisters; -begin - regs.edx := 0; - regs.ecx := 0; - GetCPUID(1,regs); - PIntegerArray(@CpuFeatures)^[0] := regs.edx; - PIntegerArray(@CpuFeatures)^[1] := regs.ecx; - GetCPUID(7,regs); - PIntegerArray(@CpuFeatures)^[2] := regs.ebx; - PIntegerArray(@CpuFeatures)^[3] := regs.ecx; - PByte(@PIntegerArray(@CpuFeatures)^[4])^ := regs.edx; -// assert(sizeof(CpuFeatures)=4*4+1); - {$ifdef Darwin} - {$ifdef CPU64} - // SSE42 asm does not (yet) work on Darwin x64 ... - Exclude(CpuFeatures, cfSSE42); - {$endif} - {$endif} -end; -{$endif CPUINTEL} - -var - crc32ctab: array[0..{$ifdef PUREPASCAL}3{$else}7{$endif},byte] of cardinal; - -function crc32cfast(crc: cardinal; buf: Pointer; len: cardinal): cardinal; -{$ifdef PUREPASCAL} -begin - result := not crc; - if (buf<>nil) and (len>0) then begin - repeat - if PtrUInt(buf) and 3=0 then // align to 4 bytes boundary - break; - result := crc32ctab[0,ToByte(result xor cardinal(buf^))] xor (result shr 8); - dec(len); - inc(buf); - until len=0; - while len>=4 do begin - result := result xor PCardinal(buf)^; - inc(buf,4); - result := crc32ctab[3,ToByte(result)] xor - crc32ctab[2,ToByte(result shr 8)] xor - crc32ctab[1,ToByte(result shr 16)] xor - crc32ctab[0,result shr 24]; - dec(len,4); - end; - while len>0 do begin - result := crc32ctab[0,ToByte(result xor cardinal(buf^))] xor (result shr 8); - dec(len); - inc(buf); - end; - end; - result := not result; -end; -{$else} -// adapted from fast Aleksandr Sharahov version -asm - test edx, edx - jz @ret - neg ecx - jz @ret - not eax - push ebx -@head: test dl, 3 - jz @aligned - movzx ebx, byte[edx] - inc edx - xor bl, al - shr eax, 8 - xor eax, dword ptr[ebx * 4 + crc32ctab] - inc ecx - jnz @head - pop ebx - not eax - ret -@ret: rep ret -@aligned: - sub edx, ecx - add ecx, 8 - jg @bodydone - push esi - push edi - mov edi, edx - mov edx, eax -@bodyloop: - mov ebx, [edi + ecx - 4] - xor edx, [edi + ecx - 8] - movzx esi, bl - mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] - movzx esi, bh - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] - shr ebx, 16 - movzx esi, bl - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] - movzx esi, bh - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] - movzx esi, dl - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 7] - movzx esi, dh - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 6] - shr edx, 16 - movzx esi, dl - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 5] - movzx esi, dh - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 4] - add ecx, 8 - jg @done - mov ebx, [edi + ecx - 4] - xor eax, [edi + ecx - 8] - movzx esi, bl - mov edx, dword ptr[esi * 4 + crc32ctab + 1024 * 3] - movzx esi, bh - xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 2] - shr ebx, 16 - movzx esi, bl - xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 1] - movzx esi, bh - xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 0] - movzx esi, al - xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 7] - movzx esi, ah - xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 6] - shr eax, 16 - movzx esi, al - xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 5] - movzx esi, ah - xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 4] - add ecx, 8 - jle @bodyloop - mov eax, edx -@done: mov edx, edi - pop edi - pop esi -@bodydone: - sub ecx, 8 - jl @tail - pop ebx - not eax - ret -@tail: movzx ebx, byte[edx + ecx] - xor bl, al - shr eax, 8 - xor eax, dword ptr[ebx * 4 + crc32ctab] - inc ecx - jnz @tail - pop ebx - not eax -end; -{$endif PUREPASCAL} - -procedure InitializeCrc32ctab; -var - i, n: integer; - crc: cardinal; -begin - // initialize tables for crc32cfast() and SymmetricEncrypt/FillRandom - for i := 0 to 255 do begin - crc := i; - for n := 1 to 8 do - if (crc and 1)<>0 then // polynom is not the same as with zlib's crc32() - crc := (crc shr 1) xor $82f63b78 else - crc := crc shr 1; - crc32ctab[0,i] := crc; - end; - for i := 0 to 255 do begin - crc := crc32ctab[0,i]; - for n := 1 to high(crc32ctab) do begin - crc := (crc shr 8) xor crc32ctab[0,ToByte(crc)]; - crc32ctab[n,i] := crc; - end; - end; -end; - -begin - {$ifdef CPUINTEL} - TestIntelCpuFeatures; - if cfSSE42 in CpuFeatures then - begin - crc32c := @crc32csse42; - mORMotHasher := @crc32csse42; - end - else - {$endif CPUINTEL} - begin - InitializeCrc32ctab; - crc32c := @crc32cfast; - mORMotHasher := @{$IFDEF CPUINTEL}xxHash32{$ELSE}xxHash32Pascal{$ENDIF}; - end; -end. - diff --git a/components/sparta/generics/source/sparta_generics.helpers.pas b/components/sparta/generics/source/sparta_generics.helpers.pas deleted file mode 100644 index 0a24a89172..0000000000 --- a/components/sparta/generics/source/sparta_generics.helpers.pas +++ /dev/null @@ -1,146 +0,0 @@ -{ - This file is part of the Free Pascal/NewPascal run time library. - Copyright (c) 2014 by Maciej Izak (hnb) - member of the NewPascal development team (http://newpascal.org) - - Copyright(c) 2004-2018 DaThoX - - It contains the generics collections 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 sparta_Generics.Helpers; - -{$MODE DELPHI}{$H+} -{$MODESWITCH TYPEHELPERS} -{$OVERFLOWCHECKS OFF} -{$RANGECHECKS OFF} - -interface - -uses - Classes, SysUtils; - -type - { TValueAnsiStringHelper } - - TValueAnsiStringHelper = record helper for AnsiString - function ToLower: AnsiString; inline; - end; - - { TValuewideStringHelper } - - TValueWideStringHelper = record helper for WideString - function ToLower: WideString; inline; - end; - - { TValueUnicodeStringHelper } - - TValueUnicodeStringHelper = record helper for UnicodeString - function ToLower: UnicodeString; inline; - end; - - { TValueShortStringHelper } - - TValueShortStringHelper = record helper for ShortString - function ToLower: ShortString; inline; - end; - - { TValueUTF8StringHelper } - - TValueUTF8StringHelper = record helper for UTF8String - function ToLower: UTF8String; inline; - end; - - { TValueRawByteStringHelper } - - TValueRawByteStringHelper = record helper for RawByteString - function ToLower: RawByteString; inline; - end; - - { TValueUInt32Helper } - - TValueUInt32Helper = record helper for UInt32 - class function GetSignMask: UInt32; static; inline; - class function GetSizedSignMask(ABits: Byte): UInt32; static; inline; - class function GetBitsLength: Byte; static; inline; - - const - SIZED_SIGN_MASK: array[1..32] of UInt32 = ( - $80000000, $C0000000, $E0000000, $F0000000, $F8000000, $FC000000, $FE000000, $FF000000, - $FF800000, $FFC00000, $FFE00000, $FFF00000, $FFF80000, $FFFC0000, $FFFE0000, $FFFF0000, - $FFFF8000, $FFFFC000, $FFFFE000, $FFFFF000, $FFFFF800, $FFFFFC00, $FFFFFE00, $FFFFFF00, - $FFFFFF80, $FFFFFFC0, $FFFFFFE0, $FFFFFFF0, $FFFFFFF8, $FFFFFFFC, $FFFFFFFE, $FFFFFFFF); - BITS_LENGTH = 32; - end; - -implementation - -{ TRawDataStringHelper } - -function TValueAnsiStringHelper.ToLower: AnsiString; -begin - Result := LowerCase(Self); -end; - -{ TValueWideStringHelper } - -function TValueWideStringHelper.ToLower: WideString; -begin - Result := LowerCase(Self); -end; - -{ TValueUnicodeStringHelper } - -function TValueUnicodeStringHelper.ToLower: UnicodeString; -begin - Result := LowerCase(Self); -end; - -{ TValueShortStringHelper } - -function TValueShortStringHelper.ToLower: ShortString; -begin - Result := LowerCase(Self); -end; - -{ TValueUTF8StringHelper } - -function TValueUTF8StringHelper.ToLower: UTF8String; -begin - Result := LowerCase(Self); -end; - -{ TValueRawByteStringHelper } - -function TValueRawByteStringHelper.ToLower: RawByteString; -begin - Result := LowerCase(Self); -end; - -{ TValueUInt32Helper } - -class function TValueUInt32Helper.GetSignMask: UInt32; -begin - Result := $80000000; -end; - -class function TValueUInt32Helper.GetSizedSignMask(ABits: Byte): UInt32; -begin - Result := SIZED_SIGN_MASK[ABits]; -end; - -class function TValueUInt32Helper.GetBitsLength: Byte; -begin - Result := BITS_LENGTH; -end; - -end. - diff --git a/components/sparta/generics/source/sparta_generics.memoryexpanders.pas b/components/sparta/generics/source/sparta_generics.memoryexpanders.pas deleted file mode 100644 index 9c69109d82..0000000000 --- a/components/sparta/generics/source/sparta_generics.memoryexpanders.pas +++ /dev/null @@ -1,227 +0,0 @@ -{ - This file is part of the Free Pascal/NewPascal run time library. - Copyright (c) 2014 by Maciej Izak (hnb) - member of the NewPascal development team (http://newpascal.org) - - Copyright(c) 2004-2018 DaThoX - - It contains the generics collections 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 sparta_Generics.MemoryExpanders; -// Memory expanders - -{$mode delphi} -{$MACRO ON} -{$OVERFLOWCHECKS OFF} -{$RANGECHECKS OFF} -{.$WARN 5024 OFF} -{.$WARN 4079 OFF} - -interface - -uses - Classes, SysUtils; - -type - TProbeSequence = class - public - end; - - { TLinearProbing } - - TLinearProbing = class(TProbeSequence) - public - class function Probe(I, Hash: UInt32): UInt32; static; inline; - - const MAX_LOAD_FACTOR = 1; - const DEFAULT_LOAD_FACTOR = 0.75; - end; - - { TQuadraticProbing } - - TQuadraticProbing = class(TProbeSequence) - public - class function Probe(I, Hash: UInt32): UInt32; static; inline; - - const MAX_LOAD_FACTOR = 0.5; - const DEFAULT_LOAD_FACTOR = 0.5; - end; - - { TDoubleHashing } - - TDoubleHashing = class(TProbeSequence) - public - class function Probe(I, Hash1: UInt32; Hash2: UInt32 = 1): UInt32; static; inline; - - const MAX_LOAD_FACTOR = 1; - const DEFAULT_LOAD_FACTOR = 0.85; - end; - -const - // http://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set - // MultiplyDeBruijnBitPosition[uint32(((numberInt32 and -numberInt32) * $077CB531)) shr 27] - MultiplyDeBruijnBitPosition: array[0..31] of Int32 = - ( - 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, - 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 - ); - - // http://primes.utm.edu/lists/2small/0bit.html - // http://www.math.niu.edu/~rusin/known-math/98/pi_x - // http://oeis.org/A014234/ - PrimaryNumbersJustLessThanPowerOfTwo: array[0..31] of UInt32 = - ( - 0, 1, 3, 7, 13, 31, 61, 127, 251, 509, 1021, 2039, 4093, 8191, 16381, 32749, 65521, 131071, - 262139, 524287, 1048573, 2097143, 4194301, 8388593, 16777213, 33554393, 67108859, - 134217689, 268435399, 536870909, 1073741789, 2147483647 - ); - - // http://oeis.org/A014210 - // http://oeis.org/A203074 - PrimaryNumbersJustBiggerThanPowerOfTwo: array[0..31] of UInt32 = ( - 2,3,5,11,17,37,67,131,257,521,1031,2053,4099, - 8209,16411,32771,65537,131101,262147,524309, - 1048583,2097169,4194319,8388617,16777259,33554467, - 67108879,134217757,268435459,536870923,1073741827, - 2147483659); - - // Fibonacci numbers - FibonacciNumbers: array[0..44] of UInt32 = ( - {0,1,1,2,3,}0,5,8,13,21,34,55,89,144,233,377,610,987, - 1597,2584,4181,6765,10946,17711,28657,46368,75025, - 121393,196418,317811,514229,832040,1346269, - 2178309,3524578,5702887,9227465,14930352,24157817, - 39088169, 63245986, 102334155, 165580141, 267914296, - 433494437, 701408733, 1134903170, 1836311903, 2971215073, - {! not fib number - this is memory limit} 4294967295); - - // Largest prime not exceeding Fibonacci(n) - // http://oeis.org/A138184/list - // http://www.numberempire.com/primenumbers.php - PrimaryNumbersJustLessThanFibonacciNumbers: array[0..44] of UInt32 = ( - {! not correlated to fib number. For empty table} 0, - 5,7,13,19,31,53,89,139,233,373,607,983,1597, - 2579,4177,6763,10939,17707,28657,46351,75017, - 121379,196387,317797,514229,832003,1346249, - 2178283,3524569,5702867,9227443,14930341,24157811, - 39088157,63245971,102334123,165580123,267914279, - 433494437,701408717,1134903127,1836311879,2971215073, - {! not correlated to fib number - this is prime memory limit} 4294967291); - - // Smallest prime >= n-th Fibonacci number. - // http://oeis.org/A138185 - PrimaryNumbersJustBiggerThanFibonacciNumbers: array[0..44] of UInt32 = ( - {! not correlated to fib number. For empty table} 0, - 5,11,13,23,37,59,89,149,233,379,613, - 991,1597,2591,4201,6779,10949,17713,28657,46381, - 75029,121403,196429,317827,514229,832063,1346273, - 2178313,3524603,5702897,9227479,14930387,24157823, - 39088193,63245989,102334157,165580147,267914303, - 433494437,701408753,1134903179,1836311951,2971215073, - {! not correlated to fib number - this is prime memory limit} 4294967291); - -type - - { TCuckooHashingCfg } - - TCuckooHashingCfg = class - public - const D = 2; - const MAX_LOAD_FACTOR = 0.5; - - class function LoadFactor(M: Integer): Integer; virtual; - end; - - TStdCuckooHashingCfg = class(TCuckooHashingCfg) - public - const MAX_LOOP = 1000; - end; - - TDeamortizedCuckooHashingCfg = class(TCuckooHashingCfg) - public - const L = 5; - end; - - TDeamortizedCuckooHashingCfg_D2 = TDeamortizedCuckooHashingCfg; - - { TDeamortizedCuckooHashingCfg_D4 } - - TDeamortizedCuckooHashingCfg_D4 = class(TDeamortizedCuckooHashingCfg) - public - const D = 4; - const L = 20; - const MAX_LOAD_FACTOR = 0.9; - - class function LoadFactor(M: Integer): Integer; override; - end; - - { TDeamortizedCuckooHashingCfg_D6 } - - TDeamortizedCuckooHashingCfg_D6 = class(TDeamortizedCuckooHashingCfg) - public - const D = 6; - const L = 170; - const MAX_LOAD_FACTOR = 0.99; - - class function LoadFactor(M: Integer): Integer; override; - end; - - TL5CuckooHashingCfg = class(TCuckooHashingCfg) - public - end; - -implementation - -{ TDeamortizedCuckooHashingCfg_D6 } - -class function TDeamortizedCuckooHashingCfg_D6.LoadFactor(M: Integer): Integer; -begin - Result:=Pred(Round(MAX_LOAD_FACTOR*M)); -end; - -{ TDeamortizedCuckooHashingCfg_D4 } - -class function TDeamortizedCuckooHashingCfg_D4.LoadFactor(M: Integer): Integer; -begin - Result:=Pred(Round(MAX_LOAD_FACTOR*M)); -end; - -{ TCuckooHashingCfg } - -class function TCuckooHashingCfg.LoadFactor(M: Integer): Integer; -begin - Result := Pred(M shr 1); -end; - -{ TLinearProbing } - -class function TLinearProbing.Probe(I, Hash: UInt32): UInt32; -begin - Result := (Hash + I) -end; - -{ TQuadraticProbing } - -class function TQuadraticProbing.Probe(I, Hash: UInt32): UInt32; -begin - Result := (Hash + Sqr(I)); -end; - -{ TDoubleHashingNoMod } - -class function TDoubleHashing.Probe(I, Hash1: UInt32; Hash2: UInt32): UInt32; -begin - Result := Hash1 + I * Hash2; -end; - -end. - diff --git a/components/sparta/generics/source/sparta_generics.strings.pas b/components/sparta/generics/source/sparta_generics.strings.pas deleted file mode 100644 index 88568dcbe2..0000000000 --- a/components/sparta/generics/source/sparta_generics.strings.pas +++ /dev/null @@ -1,37 +0,0 @@ -{ - This file is part of the Free Pascal/NewPascal run time library. - Copyright (c) 2014 by Maciej Izak (hnb) - member of the NewPascal development team (http://newpascal.org) - - Copyright(c) 2004-2018 DaThoX - - It contains the generics collections 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 sparta_Generics.Strings; - -{$mode objfpc}{$H+} - -interface - -resourcestring - SArgumentOutOfRange = 'Argument out of range'; - SArgumentNilNode = 'Node is nil'; - SDuplicatesNotAllowed = 'Duplicates not allowed in dictionary'; - SCollectionInconsistency = 'Collection inconsistency'; - SCollectionDuplicate = 'Collection does not allow duplicates'; - SDictionaryKeyDoesNotExist = 'Dictionary key does not exist'; - SItemNotFound = 'Item not found'; - -implementation - -end. - diff --git a/components/sparta/generics/sparta_generics.lpk b/components/sparta/generics/sparta_generics.lpk deleted file mode 100644 index d33e338502..0000000000 --- a/components/sparta/generics/sparta_generics.lpk +++ /dev/null @@ -1,61 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/components/sparta/generics/sparta_generics.pas b/components/sparta/generics/sparta_generics.pas deleted file mode 100644 index e6d158e3d8..0000000000 --- a/components/sparta/generics/sparta_generics.pas +++ /dev/null @@ -1,17 +0,0 @@ -{ This file was automatically created by Lazarus. Do not edit! - This source is only used to compile and install the package. - } - -unit sparta_Generics; - -{$warn 5023 off : no warning about unused units} -interface - -uses - sparta_Generics.Collections, sparta_Generics.Defaults, - sparta_Generics.Hashes, sparta_Generics.Helpers, - sparta_Generics.MemoryExpanders, sparta_Generics.Strings; - -implementation - -end. diff --git a/components/sparta/mdi/sparta_mdi.lpk b/components/sparta/mdi/sparta_mdi.lpk index bed5bb5d45..463cc5ad79 100644 --- a/components/sparta/mdi/sparta_mdi.lpk +++ b/components/sparta/mdi/sparta_mdi.lpk @@ -46,16 +46,13 @@ - - - - + - + - + diff --git a/packager/globallinks/sparta_generics-0.lpl b/packager/globallinks/sparta_generics-0.lpl deleted file mode 100644 index bba05fdef8..0000000000 --- a/packager/globallinks/sparta_generics-0.lpl +++ /dev/null @@ -1 +0,0 @@ -$(LazarusDir)/components/sparta/generics/sparta_generics.lpk