| unit Antlr.Runtime.Tools; |
| (* |
| [The "BSD licence"] |
| Copyright (c) 2008 Erik van Bilsen |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions |
| are met: |
| 1. Redistributions of source code MUST RETAIN the above copyright |
| notice, this list of conditions and the following disclaimer. |
| 2. Redistributions in binary form MUST REPRODUCE the above copyright |
| notice, this list of conditions and the following disclaimer in |
| the documentation and/or other materials provided with the |
| distribution. |
| 3. The name of the author may not be used to endorse or promote products |
| derived from this software without specific prior WRITTEN permission. |
| 4. Unless explicitly state otherwise, any contribution intentionally |
| submitted for inclusion in this work to the copyright owner or licensor |
| shall be under the terms and conditions of this license, without any |
| additional terms or conditions. |
| |
| THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR |
| IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES |
| OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. |
| IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, |
| INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT |
| NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, |
| DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY |
| THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT |
| (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF |
| THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
| *) |
| |
| interface |
| |
| {$IF CompilerVersion < 20} |
| {$MESSAGE ERROR 'You need Delphi 2009 or higher to use the Antlr runtime'} |
| {$IFEND} |
| |
| uses |
| Classes, |
| Generics.Defaults, |
| Generics.Collections; |
| |
| type |
| TSmallintArray = array of Smallint; |
| TSmallintMatrix = array of TSmallintArray; |
| TIntegerArray = array of Integer; |
| TUInt64Array = array of UInt64; |
| TStringArray = array of String; |
| |
| type |
| /// <summary> |
| /// Base interface for ANTLR objects |
| /// </summary> |
| IANTLRInterface = interface |
| ['{FA98F2EE-89D3-42A5-BC9C-1E8A9B278C3B}'] |
| function ToString: String; |
| end; |
| TANTLRInterfaceArray = array of IANTLRInterface; |
| |
| type |
| /// <summary> |
| /// Gives access to implementing object |
| /// </summary> |
| IANTLRObject = interface |
| ['{E56CE28B-8D92-4961-90ED-418A1E8FEDF2}'] |
| { Property accessors } |
| function GetImplementor: TObject; |
| |
| { Properties } |
| property Implementor: TObject read GetImplementor; |
| end; |
| |
| type |
| /// <summary> |
| /// Base for ANTLR objects |
| /// </summary> |
| TANTLRObject = class(TInterfacedObject, IANTLRInterface, IANTLRObject) |
| protected |
| { IANTLRObject } |
| function GetImplementor: TObject; |
| end; |
| |
| type |
| /// <summary> |
| /// Allows strings to be treated as object interfaces |
| /// </summary> |
| IANTLRString = interface(IANTLRInterface) |
| ['{1C7F2030-446C-4756-81E3-EC37E04E2296}'] |
| { Property accessors } |
| function GetValue: String; |
| procedure SetValue(const Value: String); |
| |
| { Properties } |
| property Value: String read GetValue write SetValue; |
| end; |
| |
| type |
| /// <summary> |
| /// Allows strings to be treated as object interfaces |
| /// </summary> |
| TANTLRString = class(TANTLRObject, IANTLRString) |
| strict private |
| FValue: String; |
| protected |
| { IANTLRString } |
| function GetValue: String; |
| procedure SetValue(const Value: String); |
| public |
| constructor Create(const AValue: String); |
| |
| function ToString: String; override; |
| end; |
| |
| type |
| /// <summary> |
| /// Win32 version of .NET's ICloneable |
| /// </summary> |
| ICloneable = interface(IANTLRInterface) |
| ['{90240BF0-3A09-46B6-BC47-C13064809F97}'] |
| { Methods } |
| function Clone: IANTLRInterface; |
| end; |
| |
| type |
| IList<T> = interface(IANTLRInterface) |
| ['{107DB2FE-A351-4F08-B9AD-E1BA8A4690FF}'] |
| { Property accessors } |
| function GetCapacity: Integer; |
| procedure SetCapacity(Value: Integer); |
| function GetCount: Integer; |
| procedure SetCount(Value: Integer); |
| function GetItem(Index: Integer): T; |
| procedure SetItem(Index: Integer; const Value: T); |
| function GetOnNotify: TCollectionNotifyEvent<T>; |
| procedure SetOnNotify(Value: TCollectionNotifyEvent<T>); |
| |
| { Methods } |
| function Add(const Value: T): Integer; |
| |
| procedure AddRange(const Values: array of T); overload; |
| procedure AddRange(const Collection: IEnumerable<T>); overload; |
| procedure AddRange(Collection: TEnumerable<T>); overload; |
| procedure AddRange(const List: IList<T>); overload; |
| |
| procedure Insert(Index: Integer; const Value: T); |
| |
| procedure InsertRange(Index: Integer; const Values: array of T); overload; |
| procedure InsertRange(Index: Integer; const Collection: IEnumerable<T>); overload; |
| procedure InsertRange(Index: Integer; const Collection: TEnumerable<T>); overload; |
| procedure InsertRange(Index: Integer; const List: IList<T>); overload; |
| |
| function Remove(const Value: T): Integer; |
| procedure Delete(Index: Integer); |
| procedure DeleteRange(AIndex, ACount: Integer); |
| function Extract(const Value: T): T; |
| |
| procedure Clear; |
| |
| function Contains(const Value: T): Boolean; |
| function IndexOf(const Value: T): Integer; |
| function LastIndexOf(const Value: T): Integer; |
| |
| procedure Reverse; |
| |
| procedure Sort; overload; |
| procedure Sort(const AComparer: IComparer<T>); overload; |
| function BinarySearch(const Item: T; out Index: Integer): Boolean; overload; |
| function BinarySearch(const Item: T; out Index: Integer; const AComparer: IComparer<T>): Boolean; overload; |
| |
| procedure TrimExcess; |
| function GetEnumerator: TList<T>.TEnumerator; |
| function GetRange(const Index, Count: Integer): IList<T>; |
| |
| { Properties } |
| |
| property Capacity: Integer read GetCapacity write SetCapacity; |
| property Count: Integer read GetCount write SetCount; |
| property Items[Index: Integer]: T read GetItem write SetItem; default; |
| property OnNotify: TCollectionNotifyEvent<T> read GetOnNotify write SetOnNotify; |
| end; |
| |
| type |
| IDictionary<TKey,TValue> = interface(IANTLRInterface) |
| ['{5937BD21-C2C8-4E30-9787-4AEFDF1072CD}'] |
| { Property accessors } |
| function GetItem(const Key: TKey): TValue; |
| procedure SetItem(const Key: TKey; const Value: TValue); |
| function GetCount: Integer; |
| |
| { Methods } |
| procedure Add(const Key: TKey; const Value: TValue); |
| procedure Remove(const Key: TKey); |
| procedure Clear; |
| procedure TrimExcess; |
| function TryGetValue(const Key: TKey; out Value: TValue): Boolean; |
| procedure AddOrSetValue(const Key: TKey; const Value: TValue); |
| function ContainsKey(const Key: TKey): Boolean; |
| function ContainsValue(const Value: TValue): Boolean; |
| function GetEnumerator: TEnumerator<TPair<TKey, TValue>>; |
| |
| { Properties } |
| property Items[const Key: TKey]: TValue read GetItem write SetItem; default; |
| property Count: Integer read GetCount; |
| end; |
| |
| type |
| TList<T> = class(Generics.Collections.TList<T>, IList<T>) |
| strict private |
| FRefCount: Integer; |
| protected |
| { IInterface } |
| function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; |
| function _AddRef: Integer; stdcall; |
| function _Release: Integer; stdcall; |
| |
| { IList<T> } |
| function GetCapacity: Integer; |
| procedure SetCapacity(Value: Integer); |
| function GetCount: Integer; |
| procedure SetCount(Value: Integer); |
| function GetItem(Index: Integer): T; |
| procedure SetItem(Index: Integer; const Value: T); |
| function GetOnNotify: TCollectionNotifyEvent<T>; |
| procedure SetOnNotify(Value: TCollectionNotifyEvent<T>); |
| function GetRange(const Index, Count: Integer): IList<T>; |
| procedure AddRange(const List: IList<T>); overload; |
| procedure InsertRange(Index: Integer; const List: IList<T>); overload; |
| end; |
| |
| type |
| TDictionaryArray<TKey,TValue> = array of IDictionary<TKey,TValue>; |
| |
| { The TDictionary class in the first release of Delphi 2009 is very buggy. |
| This is a partial copy of that class with bug fixes. } |
| TDictionary<TKey,TValue> = class(TEnumerable<TPair<TKey,TValue>>, IDictionary<TKey, TValue>) |
| private |
| type |
| TItem = record |
| HashCode: Integer; |
| Key: TKey; |
| Value: TValue; |
| end; |
| TItemArray = array of TItem; |
| private |
| FItems: TItemArray; |
| FCount: Integer; |
| FComparer: IEqualityComparer<TKey>; |
| FGrowThreshold: Integer; |
| |
| procedure SetCapacity(ACapacity: Integer); |
| procedure Rehash(NewCapPow2: Integer); |
| procedure Grow; |
| function GetBucketIndex(const Key: TKey; HashCode: Integer): Integer; |
| function Hash(const Key: TKey): Integer; |
| procedure RehashAdd(HashCode: Integer; const Key: TKey; const Value: TValue); |
| procedure DoAdd(HashCode, Index: Integer; const Key: TKey; const Value: TValue); |
| protected |
| function DoGetEnumerator: TEnumerator<TPair<TKey,TValue>>; override; |
| public |
| constructor Create(ACapacity: Integer = 0); overload; |
| constructor Create(const AComparer: IEqualityComparer<TKey>); overload; |
| constructor Create(ACapacity: Integer; const AComparer: IEqualityComparer<TKey>); overload; |
| constructor Create(Collection: TEnumerable<TPair<TKey,TValue>>); overload; |
| constructor Create(Collection: TEnumerable<TPair<TKey,TValue>>; const AComparer: IEqualityComparer<TKey>); overload; |
| destructor Destroy; override; |
| |
| type |
| TPairEnumerator = class(TEnumerator<TPair<TKey,TValue>>) |
| private |
| FDictionary: TDictionary<TKey,TValue>; |
| FIndex: Integer; |
| function GetCurrent: TPair<TKey,TValue>; |
| protected |
| function DoGetCurrent: TPair<TKey,TValue>; override; |
| function DoMoveNext: Boolean; override; |
| public |
| constructor Create(ADictionary: TDictionary<TKey,TValue>); |
| property Current: TPair<TKey,TValue> read GetCurrent; |
| function MoveNext: Boolean; |
| end; |
| protected |
| { IInterface } |
| FRefCount: Integer; |
| function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; |
| function _AddRef: Integer; stdcall; |
| function _Release: Integer; stdcall; |
| protected |
| { IDictionary<TKey, TValue> } |
| function GetItem(const Key: TKey): TValue; |
| procedure SetItem(const Key: TKey; const Value: TValue); |
| function GetCount: Integer; |
| |
| procedure Add(const Key: TKey; const Value: TValue); |
| procedure Remove(const Key: TKey); |
| procedure Clear; |
| procedure TrimExcess; |
| function TryGetValue(const Key: TKey; out Value: TValue): Boolean; |
| procedure AddOrSetValue(const Key: TKey; const Value: TValue); |
| function ContainsKey(const Key: TKey): Boolean; |
| function ContainsValue(const Value: TValue): Boolean; |
| public |
| function GetEnumerator: TEnumerator<TPair<TKey, TValue>>; |
| end; |
| |
| type |
| /// <summary> |
| /// Helper for storing local variables inside a routine. The code that ANTLR |
| /// generates contains a lot of block-level variable declarations, which |
| /// the Delphi language does not support. When generating Delphi source code, |
| /// I try to detect those declarations and move them to the routine header |
| /// as much as possible. But sometimes, this is impossible. |
| /// This is a bit of an ugly (and slow) solution, but it works. Declare an |
| /// variable of the TLocalStorage type inside a routine, and you can use it |
| /// to access variables by name. For example, see the following C code: |
| /// { |
| /// int x = 3; |
| /// { |
| /// int y = x * 2; |
| /// } |
| /// } |
| /// If the Delphi code generator cannot detect the inner "y" variable, then |
| /// it uses the local storage as follows: |
| /// var |
| /// x: Integer; |
| /// Locals: TLocalStorage; |
| /// begin |
| /// Locals.Initialize; |
| /// try |
| /// x := 3; |
| /// Locals['y'] := x * 2; |
| /// finally |
| /// Locals.Finalize; |
| /// end; |
| /// end; |
| /// </summary> |
| /// <remarks> |
| /// This is a slow solution because it involves looking up variable names. |
| /// This could be done using hashing or binary search, but this is inefficient |
| /// with small collections. Since small collections are more typical in these |
| /// scenarios, we use simple linear search here. |
| /// </remarks> |
| /// <remarks> |
| /// The TLocalStorage record has space for 256 variables. For performance |
| /// reasons, this space is preallocated on the stack and does not grow if |
| /// needed. Also, no range checking is done. But 256 local variables should |
| /// be enough for all generated code. |
| /// </remarks> |
| /// <remarks> |
| /// Also note that the variable names are case sensitive, so 'x' is a |
| /// different variable than 'X'. |
| /// </remarks> |
| /// <remarks> |
| /// TLocalStorage can only store variables that are 32 bits in size, and |
| /// supports the following data typesL |
| /// -Integer |
| /// -IInterface descendants (default property) |
| /// </remarks> |
| /// <remarks> |
| /// You MUST call the Finalize method at the end of the routine to make |
| /// sure that any stored variables of type IInterface are released. |
| /// </remarks> |
| TLocalStorage = record |
| private |
| type |
| TLocalStorageEntry = record |
| FName: String; |
| FValue: Pointer; |
| FDataType: (dtInteger, dtInterface); |
| end; |
| private |
| FEntries: array [0..255] of TLocalStorageEntry; |
| FCount: Integer; |
| function GetAsInteger(const Name: String): Integer; |
| procedure SetAsInteger(const Name: String; const Value: Integer); |
| function GetAsInterface(const Name: String): IInterface; |
| procedure SetAsInterface(const Name: String; const Value: IInterface); |
| public |
| procedure Initialize; |
| procedure Finalize; |
| |
| property Count: Integer read FCount; |
| property AsInteger[const Name: String]: Integer read GetAsInteger write SetAsInteger; |
| property AsInterface[const Name: String]: IInterface read GetAsInterface write SetAsInterface; default; |
| end; |
| |
| function InCircularRange(Bottom, Item, TopInc: Integer): Boolean; |
| |
| { Checks if A and B are implemented by the same object } |
| function SameObj(const A, B: IInterface): Boolean; |
| |
| function IfThen(const AValue: Boolean; const ATrue: IANTLRInterface; const AFalse: IANTLRInterface = nil): IANTLRInterface; overload; |
| |
| function IsUpper(const C: Char): Boolean; |
| |
| implementation |
| |
| uses |
| Windows, |
| SysUtils; |
| |
| function SameObj(const A, B: IInterface): Boolean; |
| var |
| X, Y: IInterface; |
| begin |
| if (A = nil) or (B = nil) then |
| Result := (A = B) |
| else if (A.QueryInterface(IInterface, X) = S_OK) |
| and (B.QueryInterface(IInterface, Y) = S_OK) |
| then |
| Result := (X = Y) |
| else |
| Result := (A = B); |
| end; |
| |
| function IfThen(const AValue: Boolean; const ATrue: IANTLRInterface; const AFalse: IANTLRInterface = nil): IANTLRInterface; overload; |
| begin |
| if AValue then |
| Result := ATrue |
| else |
| Result := AFalse; |
| end; |
| |
| function IsUpper(const C: Char): Boolean; |
| begin |
| Result := (C >= 'A') and (C <= 'Z'); |
| |
| end; |
| { TANTLRObject } |
| |
| function TANTLRObject.GetImplementor: TObject; |
| begin |
| Result := Self; |
| end; |
| |
| { TANTLRString } |
| |
| constructor TANTLRString.Create(const AValue: String); |
| begin |
| inherited Create; |
| FValue := AValue; |
| end; |
| |
| function TANTLRString.GetValue: String; |
| begin |
| Result := FValue; |
| end; |
| |
| procedure TANTLRString.SetValue(const Value: String); |
| begin |
| FValue := Value; |
| end; |
| |
| function TANTLRString.ToString: String; |
| begin |
| Result := FValue; |
| end; |
| |
| { TList<T> } |
| |
| procedure TList<T>.AddRange(const List: IList<T>); |
| begin |
| InsertRange(GetCount, List); |
| end; |
| |
| function TList<T>.GetCapacity: Integer; |
| begin |
| Result := inherited Capacity; |
| end; |
| |
| function TList<T>.GetCount: Integer; |
| begin |
| Result := inherited Count; |
| end; |
| |
| function TList<T>.GetItem(Index: Integer): T; |
| begin |
| Result := inherited Items[Index]; |
| end; |
| |
| function TList<T>.GetOnNotify: TCollectionNotifyEvent<T>; |
| begin |
| Result := inherited OnNotify; |
| end; |
| |
| function TList<T>.GetRange(const Index, Count: Integer): IList<T>; |
| var |
| I: Integer; |
| begin |
| Result := TList<T>.Create; |
| Result.Capacity := Count; |
| for I := Index to Index + Count - 1 do |
| Result.Add(GetItem(I)); |
| end; |
| |
| procedure TList<T>.InsertRange(Index: Integer; const List: IList<T>); |
| var |
| Item: T; |
| begin |
| for Item in List do |
| begin |
| Insert(Index, Item); |
| Inc(Index); |
| end; |
| end; |
| |
| function TList<T>.QueryInterface(const IID: TGUID; out Obj): HResult; |
| begin |
| if GetInterface(IID, Obj) then |
| Result := 0 |
| else |
| Result := E_NOINTERFACE; |
| end; |
| |
| procedure TList<T>.SetCapacity(Value: Integer); |
| begin |
| inherited Capacity := Value; |
| end; |
| |
| procedure TList<T>.SetCount(Value: Integer); |
| begin |
| inherited Count := Value; |
| end; |
| |
| procedure TList<T>.SetItem(Index: Integer; const Value: T); |
| begin |
| inherited Items[Index] := Value; |
| end; |
| |
| procedure TList<T>.SetOnNotify(Value: TCollectionNotifyEvent<T>); |
| begin |
| inherited OnNotify := Value; |
| end; |
| |
| function TList<T>._AddRef: Integer; |
| begin |
| Result := InterlockedIncrement(FRefCount); |
| end; |
| |
| function TList<T>._Release: Integer; |
| begin |
| Result := InterlockedDecrement(FRefCount); |
| if (Result = 0) then |
| Destroy; |
| end; |
| |
| { TDictionary<TKey, TValue> } |
| |
| procedure TDictionary<TKey,TValue>.Rehash(NewCapPow2: Integer); |
| var |
| oldItems, newItems: TItemArray; |
| i: Integer; |
| begin |
| if NewCapPow2 = Length(FItems) then |
| Exit |
| else if NewCapPow2 < 0 then |
| OutOfMemoryError; |
| |
| oldItems := FItems; |
| SetLength(newItems, NewCapPow2); |
| FItems := newItems; |
| FGrowThreshold := NewCapPow2 shr 1 + NewCapPow2 shr 2; |
| |
| for i := 0 to Length(oldItems) - 1 do |
| if oldItems[i].HashCode <> 0 then |
| RehashAdd(oldItems[i].HashCode, oldItems[i].Key, oldItems[i].Value); |
| end; |
| |
| procedure TDictionary<TKey,TValue>.SetCapacity(ACapacity: Integer); |
| var |
| newCap: Integer; |
| begin |
| if ACapacity < FCount then |
| raise EArgumentOutOfRangeException.CreateRes(@sArgumentOutOfRange); |
| |
| if ACapacity = 0 then |
| Rehash(0) |
| else |
| begin |
| newCap := 4; |
| while newCap < ACapacity do |
| newCap := newCap shl 1; |
| Rehash(newCap); |
| end |
| end; |
| |
| procedure TDictionary<TKey,TValue>.Grow; |
| var |
| newCap: Integer; |
| begin |
| newCap := Length(FItems) * 2; |
| if newCap = 0 then |
| newCap := 4; |
| Rehash(newCap); |
| end; |
| |
| function TDictionary<TKey,TValue>.GetBucketIndex(const Key: TKey; HashCode: Integer): Integer; |
| var |
| start, hc: Integer; |
| begin |
| if Length(FItems) = 0 then |
| Exit(not High(Integer)); |
| |
| start := HashCode and (Length(FItems) - 1); |
| Result := start; |
| while True do |
| begin |
| hc := FItems[Result].HashCode; |
| |
| // Not found: return complement of insertion point. |
| if hc = 0 then |
| Exit(not Result); |
| |
| // Found: return location. |
| if (hc = HashCode) and FComparer.Equals(FItems[Result].Key, Key) then |
| Exit(Result); |
| |
| Inc(Result); |
| if Result >= Length(FItems) then |
| Result := 0; |
| end; |
| end; |
| |
| function TDictionary<TKey, TValue>.GetCount: Integer; |
| begin |
| Result := FCount; |
| end; |
| |
| function TDictionary<TKey,TValue>.Hash(const Key: TKey): Integer; |
| const |
| PositiveMask = not Integer($80000000); |
| begin |
| // Double-Abs to avoid -MaxInt and MinInt problems. |
| // Not using compiler-Abs because we *must* get a positive integer; |
| // for compiler, Abs(Low(Integer)) is a null op. |
| Result := PositiveMask and ((PositiveMask and FComparer.GetHashCode(Key)) + 1); |
| end; |
| |
| function TDictionary<TKey,TValue>.GetItem(const Key: TKey): TValue; |
| var |
| index: Integer; |
| begin |
| index := GetBucketIndex(Key, Hash(Key)); |
| if index < 0 then |
| raise EListError.CreateRes(@sGenericItemNotFound); |
| Result := FItems[index].Value; |
| end; |
| |
| procedure TDictionary<TKey,TValue>.SetItem(const Key: TKey; const Value: TValue); |
| var |
| index: Integer; |
| oldValue: TValue; |
| begin |
| index := GetBucketIndex(Key, Hash(Key)); |
| if index < 0 then |
| raise EListError.CreateRes(@sGenericItemNotFound); |
| |
| oldValue := FItems[index].Value; |
| FItems[index].Value := Value; |
| end; |
| |
| procedure TDictionary<TKey,TValue>.RehashAdd(HashCode: Integer; const Key: TKey; const Value: TValue); |
| var |
| index: Integer; |
| begin |
| index := not GetBucketIndex(Key, HashCode); |
| FItems[index].HashCode := HashCode; |
| FItems[index].Key := Key; |
| FItems[index].Value := Value; |
| end; |
| |
| function TDictionary<TKey, TValue>.QueryInterface(const IID: TGUID; |
| out Obj): HResult; |
| begin |
| if GetInterface(IID, Obj) then |
| Result := 0 |
| else |
| Result := E_NOINTERFACE; |
| end; |
| |
| function TDictionary<TKey, TValue>._AddRef: Integer; |
| begin |
| Result := InterlockedIncrement(FRefCount); |
| end; |
| |
| function TDictionary<TKey, TValue>._Release: Integer; |
| begin |
| Result := InterlockedDecrement(FRefCount); |
| if (Result = 0) then |
| Destroy; |
| end; |
| |
| constructor TDictionary<TKey,TValue>.Create(ACapacity: Integer = 0); |
| begin |
| Create(ACapacity, nil); |
| end; |
| |
| constructor TDictionary<TKey,TValue>.Create(const AComparer: IEqualityComparer<TKey>); |
| begin |
| Create(0, AComparer); |
| end; |
| |
| constructor TDictionary<TKey,TValue>.Create(ACapacity: Integer; const AComparer: IEqualityComparer<TKey>); |
| var |
| cap: Integer; |
| begin |
| inherited Create; |
| if ACapacity < 0 then |
| raise EArgumentOutOfRangeException.CreateRes(@sArgumentOutOfRange); |
| FComparer := AComparer; |
| if FComparer = nil then |
| FComparer := TEqualityComparer<TKey>.Default; |
| SetCapacity(ACapacity); |
| end; |
| |
| constructor TDictionary<TKey, TValue>.Create( |
| Collection: TEnumerable<TPair<TKey, TValue>>); |
| var |
| item: TPair<TKey,TValue>; |
| begin |
| Create(0, nil); |
| for item in Collection do |
| AddOrSetValue(item.Key, item.Value); |
| end; |
| |
| constructor TDictionary<TKey, TValue>.Create( |
| Collection: TEnumerable<TPair<TKey, TValue>>; |
| const AComparer: IEqualityComparer<TKey>); |
| var |
| item: TPair<TKey,TValue>; |
| begin |
| Create(0, AComparer); |
| for item in Collection do |
| AddOrSetValue(item.Key, item.Value); |
| end; |
| |
| destructor TDictionary<TKey,TValue>.Destroy; |
| begin |
| Clear; |
| inherited; |
| end; |
| |
| procedure TDictionary<TKey,TValue>.Add(const Key: TKey; const Value: TValue); |
| var |
| index, hc: Integer; |
| begin |
| if FCount >= FGrowThreshold then |
| Grow; |
| |
| hc := Hash(Key); |
| index := GetBucketIndex(Key, hc); |
| if index >= 0 then |
| raise EListError.CreateRes(@sGenericDuplicateItem); |
| |
| DoAdd(hc, not index, Key, Value); |
| end; |
| |
| function InCircularRange(Bottom, Item, TopInc: Integer): Boolean; |
| begin |
| Result := (Bottom < Item) and (Item <= TopInc) // normal |
| or (TopInc < Bottom) and (Item > Bottom) // top wrapped |
| or (TopInc < Bottom) and (Item <= TopInc) // top and item wrapped |
| end; |
| |
| procedure TDictionary<TKey,TValue>.Remove(const Key: TKey); |
| var |
| gap, index, hc, bucket: Integer; |
| oldValue: TValue; |
| begin |
| hc := Hash(Key); |
| index := GetBucketIndex(Key, hc); |
| if index < 0 then |
| Exit; |
| |
| // Removing item from linear probe hash table is moderately |
| // tricky. We need to fill in gaps, which will involve moving items |
| // which may not even hash to the same location. |
| // Knuth covers it well enough in Vol III. 6.4.; but beware, Algorithm R |
| // (2nd ed) has a bug: step R4 should go to step R1, not R2 (already errata'd). |
| // My version does linear probing forward, not backward, however. |
| |
| // gap refers to the hole that needs filling-in by shifting items down. |
| // index searches for items that have been probed out of their slot, |
| // but being careful not to move items if their bucket is between |
| // our gap and our index (so that they'd be moved before their bucket). |
| // We move the item at index into the gap, whereupon the new gap is |
| // at the index. If the index hits a hole, then we're done. |
| |
| // If our load factor was exactly 1, we'll need to hit this hole |
| // in order to terminate. Shouldn't normally be necessary, though. |
| FItems[index].HashCode := 0; |
| |
| gap := index; |
| while True do |
| begin |
| Inc(index); |
| if index = Length(FItems) then |
| index := 0; |
| |
| hc := FItems[index].HashCode; |
| if hc = 0 then |
| Break; |
| |
| bucket := hc and (Length(FItems) - 1); |
| if not InCircularRange(gap, bucket, index) then |
| begin |
| FItems[gap] := FItems[index]; |
| gap := index; |
| // The gap moved, but we still need to find it to terminate. |
| FItems[gap].HashCode := 0; |
| end; |
| end; |
| |
| FItems[gap].HashCode := 0; |
| FItems[gap].Key := Default(TKey); |
| oldValue := FItems[gap].Value; |
| FItems[gap].Value := Default(TValue); |
| Dec(FCount); |
| end; |
| |
| procedure TDictionary<TKey,TValue>.Clear; |
| begin |
| FCount := 0; |
| FGrowThreshold := 0; |
| SetLength(FItems, 0); |
| SetCapacity(0); |
| end; |
| |
| procedure TDictionary<TKey,TValue>.TrimExcess; |
| begin |
| SetCapacity(FCount); |
| end; |
| |
| function TDictionary<TKey,TValue>.TryGetValue(const Key: TKey; out Value: TValue): Boolean; |
| var |
| index: Integer; |
| begin |
| index := GetBucketIndex(Key, Hash(Key)); |
| Result := index >= 0; |
| if Result then |
| Value := FItems[index].Value |
| else |
| Value := Default(TValue); |
| end; |
| |
| procedure TDictionary<TKey,TValue>.DoAdd(HashCode, Index: Integer; const Key: TKey; const Value: TValue); |
| begin |
| FItems[Index].HashCode := HashCode; |
| FItems[Index].Key := Key; |
| FItems[Index].Value := Value; |
| Inc(FCount); |
| end; |
| |
| function TDictionary<TKey, TValue>.DoGetEnumerator: TEnumerator<TPair<TKey, TValue>>; |
| begin |
| Result := GetEnumerator; |
| end; |
| |
| procedure TDictionary<TKey,TValue>.AddOrSetValue(const Key: TKey; const Value: TValue); |
| begin |
| if ContainsKey(Key) then |
| SetItem(Key,Value) |
| else |
| Add(Key,Value); |
| end; |
| |
| function TDictionary<TKey,TValue>.ContainsKey(const Key: TKey): Boolean; |
| begin |
| Result := GetBucketIndex(Key, Hash(Key)) >= 0; |
| end; |
| |
| function TDictionary<TKey,TValue>.ContainsValue(const Value: TValue): Boolean; |
| var |
| i: Integer; |
| c: IEqualityComparer<TValue>; |
| begin |
| c := TEqualityComparer<TValue>.Default; |
| |
| for i := 0 to Length(FItems) - 1 do |
| if (FItems[i].HashCode <> 0) and c.Equals(FItems[i].Value, Value) then |
| Exit(True); |
| Result := False; |
| end; |
| |
| function TDictionary<TKey,TValue>.GetEnumerator: TPairEnumerator; |
| begin |
| Result := TPairEnumerator.Create(Self); |
| end; |
| |
| // Pairs |
| |
| constructor TDictionary<TKey,TValue>.TPairEnumerator.Create(ADictionary: TDictionary<TKey,TValue>); |
| begin |
| inherited Create; |
| FIndex := -1; |
| FDictionary := ADictionary; |
| end; |
| |
| function TDictionary<TKey, TValue>.TPairEnumerator.DoGetCurrent: TPair<TKey, TValue>; |
| begin |
| Result := GetCurrent; |
| end; |
| |
| function TDictionary<TKey, TValue>.TPairEnumerator.DoMoveNext: Boolean; |
| begin |
| Result := MoveNext; |
| end; |
| |
| function TDictionary<TKey,TValue>.TPairEnumerator.GetCurrent: TPair<TKey,TValue>; |
| begin |
| Result.Key := FDictionary.FItems[FIndex].Key; |
| Result.Value := FDictionary.FItems[FIndex].Value; |
| end; |
| |
| function TDictionary<TKey,TValue>.TPairEnumerator.MoveNext: Boolean; |
| begin |
| while FIndex < Length(FDictionary.FItems) - 1 do |
| begin |
| Inc(FIndex); |
| if FDictionary.FItems[FIndex].HashCode <> 0 then |
| Exit(True); |
| end; |
| Result := False; |
| end; |
| |
| { TLocalStorage } |
| |
| procedure TLocalStorage.Finalize; |
| var |
| I: Integer; |
| begin |
| for I := 0 to FCount - 1 do |
| if (FEntries[I].FDataType = dtInterface) then |
| IInterface(FEntries[I].FValue) := nil; |
| end; |
| |
| function TLocalStorage.GetAsInteger(const Name: String): Integer; |
| var |
| I: Integer; |
| begin |
| for I := 0 to FCount - 1 do |
| if (FEntries[I].FName = Name) then |
| Exit(Integer(FEntries[I].FValue)); |
| Result := 0; |
| end; |
| |
| function TLocalStorage.GetAsInterface(const Name: String): IInterface; |
| var |
| I: Integer; |
| begin |
| for I := 0 to FCount - 1 do |
| if (FEntries[I].FName = Name) then |
| Exit(IInterface(FEntries[I].FValue)); |
| Result := nil; |
| end; |
| |
| procedure TLocalStorage.Initialize; |
| begin |
| FCount := 0; |
| end; |
| |
| procedure TLocalStorage.SetAsInteger(const Name: String; const Value: Integer); |
| var |
| I: Integer; |
| begin |
| for I := 0 to FCount - 1 do |
| if (FEntries[I].FName = Name) then |
| begin |
| FEntries[I].FValue := Pointer(Value); |
| Exit; |
| end; |
| FEntries[FCount].FName := Name; |
| FEntries[FCount].FValue := Pointer(Value); |
| FEntries[FCount].FDataType := dtInteger; |
| Inc(FCount); |
| end; |
| |
| procedure TLocalStorage.SetAsInterface(const Name: String; |
| const Value: IInterface); |
| var |
| I: Integer; |
| begin |
| for I := 0 to FCount - 1 do |
| if (FEntries[I].FName = Name) then |
| begin |
| IInterface(FEntries[I].FValue) := Value; |
| Exit; |
| end; |
| FEntries[FCount].FName := Name; |
| FEntries[FCount].FValue := nil; |
| IInterface(FEntries[FCount].FValue) := Value; |
| FEntries[FCount].FDataType := dtInterface; |
| Inc(FCount); |
| end; |
| |
| end. |