From d1513555db15a61e1e3ae061dcb10d5cd0d1d5fa Mon Sep 17 00:00:00 2001 From: "R. Beltran" Date: Mon, 6 Nov 2023 00:49:20 +0100 Subject: [PATCH 1/3] update ToString to allow nested dictionaries --- ArrayListLib/Sources/ArrayList.twin | 4 ++-- ArrayListLib/Sources/IArrayList.twin | 2 +- ArrayListLib/Sources/ListRange.twin | 4 ++-- ArrayListLib/Sources/Modules/CommonModule.twin | 12 +++++++++--- 4 files changed, 14 insertions(+), 8 deletions(-) diff --git a/ArrayListLib/Sources/ArrayList.twin b/ArrayListLib/Sources/ArrayList.twin index 89844c0..24a14b0 100644 --- a/ArrayListLib/Sources/ArrayList.twin +++ b/ArrayListLib/Sources/ArrayList.twin @@ -307,8 +307,8 @@ Public Class ArrayList ReassignArrayTo ToArray, t End Function - Public Function ToString(Optional TextQualifier As String = """", Optional ByVal UseNullAsEmpty As Boolean = True) As String Implements IArrayList.ToString - Return CommonModule.Stringify(Me, TextQualifier, UseNullAsEmpty) + Public Function ToString(Optional TextQualifier As String = """", Optional ByVal UseNullAsEmpty As Boolean = True, Optional ByVal UnquotedKeysAllowed As Boolean = False) As String Implements IArrayList.ToString + Return CommonModule.Stringify(Me, TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) End Function Public Sub AddRange(Target As Variant) Implements IArrayList.AddRange diff --git a/ArrayListLib/Sources/IArrayList.twin b/ArrayListLib/Sources/IArrayList.twin index f7d49bb..bb57ae0 100644 --- a/ArrayListLib/Sources/IArrayList.twin +++ b/ArrayListLib/Sources/IArrayList.twin @@ -53,7 +53,7 @@ Public Interface IListRange Extends IList Sub RemoveRange(ByVal Index As Long, ByVal GetCount As Long) Sub SetRange(ByVal Index As Long, Target As Variant) Function ToArray() As Variant() - Function ToString(TextQualifier As String, ByVal UseNullAsEmpty As Boolean) As String + Function ToString(Optional TextQualifier As String, Optional ByVal UseNullAsEmpty As Boolean, Optional ByVal UnquotedKeysAllowed As Boolean) As String [ Description ("Sorts the elements in a section of this list. The sort compares the elements to each other using the given IComparer interface.") ] Sub Sort(Optional ByVal Index As Variant, Optional ByVal GetCount As Variant, Optional ByRef Comparer As IComparer = Nothing) Function BinarySearch(ByVal Index As Long, ByVal GetCount As Long, ByRef Value As Variant, Optional ByRef Comparer As IComparer = Nothing) As Long diff --git a/ArrayListLib/Sources/ListRange.twin b/ArrayListLib/Sources/ListRange.twin index f98f9d6..2442114 100644 --- a/ArrayListLib/Sources/ListRange.twin +++ b/ArrayListLib/Sources/ListRange.twin @@ -331,8 +331,8 @@ Public Class ListRange ReassignArrayTo ToArray, t End Function - Public Function ToString(Optional TextQualifier As String = """", Optional ByVal UseNullAsEmpty As Boolean = True) As String Implements ArrayList.ToString, IArrayList.ToString - Return CommonModule.Stringify(Me, TextQualifier, UseNullAsEmpty) + Public Function ToString(Optional TextQualifier As String = """", Optional ByVal UseNullAsEmpty As Boolean = True, Optional ByVal UnquotedKeysAllowed As Boolean = False) As String Implements ArrayList.ToString, IArrayList.ToString + Return CommonModule.Stringify(Me, TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) End Function #Region "HIDDEN METHODS IN MSCORLIB" diff --git a/ArrayListLib/Sources/Modules/CommonModule.twin b/ArrayListLib/Sources/Modules/CommonModule.twin index c62ec17..38e8379 100644 --- a/ArrayListLib/Sources/Modules/CommonModule.twin +++ b/ArrayListLib/Sources/Modules/CommonModule.twin @@ -1,7 +1,7 @@ Module CommonModule [ Hidden ] - Public Function Stringify(Value As Variant, TextQualifier As String, ByVal UseNullAsEmpty As Boolean) As String + Public Function Stringify(Value As Variant, TextQualifier As String, ByVal UseNullAsEmpty As Boolean, ByVal UnquotedKeysAllowed As Boolean) As String Select Case VarType(Value) Case vbString: Return TextQualifier & Replace(Value, TextQualifier, TextQualifier & TextQualifier) & TextQualifier Case vbNull: Return "null" @@ -12,11 +12,17 @@ Module CommonModule On Error Resume Next If IsObject(Value) AndAlso TypeOf Value Is ListRange Then For Each v In CListRange(Value) - s = s & ", " & Stringify(v, TextQualifier, UseNullAsEmpty) + s = s & ", " & Stringify(v, TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) Next v + ElseIf IsObject(Value) AndAlso InStr(TypeName(Value), "Dictionary", Compare:=VbCompareMethod.vbBinaryCompare) >= 0 Then + For Each v In Value.Keys + s = s & ", " & Stringify(If(UnquotedKeysAllowed, v, LTrim(Str(v))), TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) & ": " & Stringify(Value(v), TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) + Next v + On Error GoTo 0 + Return "{" & VBA.Mid$(s, 3) & "}" Else For Each v In Value - s = s & ", " & Stringify(v, TextQualifier, UseNullAsEmpty) + s = s & ", " & Stringify(v, TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) Next v End If On Error GoTo 0 From 1b86af8508868d63ba815a4923de704df0048655 Mon Sep 17 00:00:00 2001 From: "R. Beltran" Date: Mon, 6 Nov 2023 00:49:32 +0100 Subject: [PATCH 2/3] update project files --- ArrayListLib.twinproj | Bin 79012 -> 79838 bytes ArrayListLib/Settings | 2 +- 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/ArrayListLib.twinproj b/ArrayListLib.twinproj index 057a87ba4ab8d53ce917171e2f46ad029a6f0a24..9825ffeb162b9a70a7f289ab017606df7b8f7de6 100644 GIT binary patch delta 1023 zcmbVKO=uHA6wc@d+omR#CQXZJGseX1%CgvsVoM_=ZG_aOfu;se;-))kR`w^|owP&| za`LKSl=NbIs5h~-?jZ*eJr+SLo)kgqNqQ2&tLP*tRUw7q9A+MGzW2WG{XE)XK7V8G zg*$=GZnN106=Bg?`x*oeLwJ5pY{Xj0=6~^NF$78ZO$C74ST^y1`O4@eP9JtI3F=q-A+s) zd*_pNe|0o+o`LZmD*mip!8If9nEfWul`{>ivqlsc{zRb+@*Hw3&WYmR4kP%n96b~{h* z>7qu)dTUIjbsn&vMppi%>yK5#9&g+t}kd4WjXq0xn99duTHJHnz40#>yAa_~2U8t`M`M%lH z`1uv?;}SWx#VYY|frpbbhODx6O$!{y5h(kITGq(HQ!p?B1N5O_y4Z5A)KpIc>tP3K zO|wk`ccLLJ#kKX_s%Ol^qC!%Zf~?8Ivkj)(0kZL&qA&K5Kc!tg5Qm!#B)pcueK;U7s|>_Kf=kVAS%GXz~Gaa#CQV!nHYFw3KnOm8k4w5m6OEMg}gRtdFO& ft6wlgT36sD%j8e|I$W$k3BBCZl0@E(#(VhzB-@AR diff --git a/ArrayListLib/Settings b/ArrayListLib/Settings index 131e0d9..68bc791 100644 --- a/ArrayListLib/Settings +++ b/ArrayListLib/Settings @@ -32,7 +32,7 @@ "project.settingsVersion": 1, "project.useProjectIdForTypeLibraryId": true, "project.versionAutoIncrement": "Revision", - "project.versionBuild": 1, + "project.versionBuild": 2, "project.versionLegalCopyright": "This is free and unencumbered software released into the public domain. For more information, please refer to ", "project.versionMajor": 1, "project.versionMinor": 6, From 16322cb2460847dee8eb3ed7b16359b6c86a4b26 Mon Sep 17 00:00:00 2001 From: "R. Beltran" Date: Tue, 14 Nov 2023 19:28:18 +0100 Subject: [PATCH 3/3] large refactoring for Enumerator related code --- ArrayListLib/Sources/ArrayList.twin | 1248 +++++++++-------- ArrayListLib/Sources/Enumerator.twin | 301 ++-- ArrayListLib/Sources/IArrayList.twin | 170 +-- ArrayListLib/Sources/ListRange.twin | 776 +++++----- .../Sources/Modules/CommonModule.twin | 152 +- ArrayListLib/Sources/Modules/LibMemory.twin | 211 +-- ArrayListLib/Sources/Modules/LibMemoryEx.twin | 226 +-- 7 files changed, 1606 insertions(+), 1478 deletions(-) diff --git a/ArrayListLib/Sources/ArrayList.twin b/ArrayListLib/Sources/ArrayList.twin index 24a14b0..f7d06e6 100644 --- a/ArrayListLib/Sources/ArrayList.twin +++ b/ArrayListLib/Sources/ArrayList.twin @@ -1,619 +1,629 @@ - -[ ClassId ("E88D5510-C8E5-433D-8DA5-712D8586E0C9") ] -[ COMCreatable (True) ] -Public Class ArrayList - Implements IArrayList - Implements ICloneable - - Private pItems() As Variant - Private pIndex As Long - Private pVersion As Long - Private pBaseIndex As Long - - Public Sub New(Optional ByVal Capacity As Long = 2, Optional ByVal BaseIndex As Long = 0) - ReDim pItems(0 To Capacity - 1) - pBaseIndex = BaseIndex - End Sub - - [ DefaultMember ] - Public Property Get Item(ByVal Index As Long) As Variant Implements IArrayList.Item - If Index < pBaseIndex Or Index >= pIndex + pBaseIndex Then Err.Raise 9 - Return pItems(Index - pBaseIndex) - End Property - - Public Property Let Item(ByVal Index As Long, Value As Variant) Implements IArrayList.Item - If Index < pBaseIndex Or Index >= pIndex + pBaseIndex Then Err.Raise 9 - pItems(Index - pBaseIndex) = Value - pVersion += 1 - End Property - - Public Property Set Item(ByVal Index As Long, Value As Variant) Implements IArrayList.Item - If Index < pBaseIndex Or Index >= pIndex + pBaseIndex Then Err.Raise 9 - Set pItems(Index - pBaseIndex) = Value - pVersion += 1 - End Property - - Public Property Get Count() As Long Implements IArrayList.Count: Return pIndex: End Property - - Public Property Let Count(ByVal Value As Long) - If Value < 0 Then Err.Raise 9 - If Value > pIndex Then GrowCapacity(Value - pIndex) - pIndex = Value - pVersion += 1 - End Property - - Public Property Get BaseIndex() As Long Implements IArrayList.BaseIndex: Return pBaseIndex: End Property - - Public Property Let BaseIndex(Value As Long) Implements IArrayList.BaseIndex: pBaseIndex = Value: pVersion += 1: End Property - [ Hidden ] - Public Property Get Version() As Long Implements IArrayList.Version: Return pVersion: End Property - - Public Property Get Capacity() As Long Implements IArrayList.Capacity: Return UBound(pItems) + 1: End Property - - Public Property Let Capacity(Value As Long) Implements IArrayList.Capacity: ReDim Preserve pItems(LBound(pItems) To Value - 1): End Property - [ Hidden ] - Public Property Get IsFixedSize() As Boolean Implements IArrayList.IsFixedSize: Return False: End Property - [ Hidden ] - Public Property Get IsReadOnly() As Boolean Implements IArrayList.IsReadOnly: Return False: End Property - [ Hidden ] - Public Property Get IsSynchronized() As Boolean Implements IArrayList.IsSynchronized: Return False: End Property - [ Hidden ] - Public Property Get SyncRoot() As Variant Implements IArrayList.SyncRoot: Return Nothing: End Property - - [ Hidden ] - [ Description ("CAUTION: Limit usage only in For Each In .Items calls, do NOT assign the return value of .Items to another variable unless you know what you're doing.") ] - Public Function Items() As Variant() Implements IArrayList.Items - /* Returns a 0-based Variant Array pointing to the same memory as the internal array of this list - * without increasing the reference count of byref elements within the list. - * If you assign this array to a variable in your code, you must remove the reference - * before it goes out of scope to prevent double deallocation of byref values. - */ - Static sa As SAFEARRAY_1D - With sa - .cDims = 1 - .cbElements = VARIANT_SIZE - .fFeatures = FADF_VARIANT Or FADF_AUTO - .cLocks = 10 - .pvData = VarPtr(pItems(0)) - .rgsabound0.cElements = pIndex - End With - VBA.PutMemPtr VarPtrArr(Items), VarPtr(sa) - End Function - - [ Description ("Adds an item to the list. The return value is the position the new element was inserted in.") ] - Public Function Add(Value As Variant) As Long Implements IArrayList.Add - If pIndex > UBound(pItems) Then GrowCapacity 1 - If IsObject(Value) Then Set pItems(pIndex) = Value Else pItems(pIndex) = Value - Add = pIndex + pBaseIndex - pIndex += 1 - pVersion += 1 - End Function - - [ Description ("Removes all items from the list.") ] - Public Sub Clear() Implements IArrayList.Clear - Erase pItems - ReDim pItems(0 To 1) - pIndex = 0 - pVersion += 1 - End Sub - - [ Description ("Creates a shallow copy of this ArrayList.") ] - Public Function Clone() As Variant Implements ICloneable.Clone - Dim Target As ArrayList - Set Target = New ArrayList(BaseIndex:=pBaseIndex) - C2IArrayList(Target).CloneTo Target, C2IArrayList(Me), 0, pIndex - Return Target - End Function - - [ Description ("Returns whether the list contains a particular item.") ] - Public Function Contains(Value As Variant) As Boolean Implements IArrayList.Contains - Dim i As Long, vt As VbVarType = VarType(Value) - Select Case vt - Case vbNull - For i = 0 To pIndex - 1 - If IsNull(pItems(i)) Then Return True - Next i - Case vbObject - For i = 0 To pIndex - 1 - If VarType(pItems(i)) = vt AndAlso ObjPtr(pItems(i)) = ObjPtr(Value) Then Return True - Next i - Case Else - For i = 0 To pIndex - 1 - If VarType(pItems(i)) = vt AndAlso pItems(i) = Value Then Return True - Next i - End Select - End Function - - [ Description ("Copies this ArrayList to another array at specified index, the other array must be of a compatible array type but not necessarily the same type. It also accepts other lists implementing IListRange as target.") ] - Public Sub CopyTo(Target As Variant, Index As Long) Implements IArrayList.CopyTo - Select Case VarType(Target) - Case vbObject - If TypeOf Target Is IListRange Then - C2IListRange(Target).SetRange Index, Me - Else - Err.Raise 13 - End If - Case vbArray + vbVariant - If Index < 0 Or Index > UBound(Target) Then Err.Raise 9 - If UBound(Target) - Index < pIndex Then Err.Raise 6 - VariantArrayClone VarPtr(Target(Index)), VarPtr(pItems(0)), pIndex - Case Else - If Not IsArray(Target) Then Err.Raise 13 - If Index < 0 Or Index > UBound(Target) Then Err.Raise 9 - If UBound(Target) - Index < pIndex Then Err.Raise 6 - Dim i As Long - For i = 0 To pIndex - 1 - Assign Target(Index + i), pItems(i) - Next i - End Select - End Sub - - [ Enumerator ] - [ Description ("When using this enumerator for more advanced usage other than regular For Each usage, Index is always 0-based regardless of the current BaseIndex value in this ArrayList.") ] - Public Function GetEnumerator(Optional ByVal Index As Long = 0, Optional ByVal GetCount As Variant, Optional ByVal GetStep As Long = 1, Optional ByRef ThisEnumerator As IEnumerator) As stdole.IUnknown Implements IArrayList.GetEnumerator - Static mEnumerator As Enumerator, mEnumeratorB As Enumerator, mVer As Long, mVerB As Long - If IsMissing(GetCount) Then GetCount = pIndex - Index - If GetCount > 0 Then - If mEnumerator Is Nothing Then - Set mEnumerator = New Enumerator(pItems, Index, GetCount, GetStep, ThisEnumerator) - mVer = pVersion - Else - If pVersion <> mVer Then - mEnumerator.Bind pItems, Index, GetCount, GetStep - mVer = pVersion - Else - If Not mEnumerator.IsAvailable Then - If mEnumeratorB Is Nothing Then - Set mEnumeratorB = New Enumerator(pItems, Index, GetCount, GetStep, ThisEnumerator) - mVerB = pVersion - ElseIf pVersion <> mVerB Then - mEnumeratorB.Bind pItems, Index, GetCount, GetStep - mVerB = pVersion - End If - Set ThisEnumerator = mEnumeratorB - Return mEnumeratorB - End If - End If - End If - Set ThisEnumerator = mEnumerator - Return mEnumerator - End If - End Function - - [ Description ("Returns the index of a particular item. Returns -1 if the item isn't in the list.") ] - Public Function IndexOf(Value As Variant, Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) As Long Implements IArrayList.IndexOf - If IsMissing(Index) Then Index = pBaseIndex - Index = CLng(Index - pBaseIndex) - If IsMissing(GetCount) Then GetCount = pIndex - Index - If Index > pIndex Or GetCount < 0 Or Index > pIndex - GetCount Then Err.Raise 9 - GetCount = Index + GetCount - 1 - If pIndex = 0 Then Return -1 - Dim i As Long, vt As VbVarType = VarType(Value) - Select Case vt - Case vbNull - For i = Index To GetCount - If IsNull(pItems(i)) Then Return i + pBaseIndex - Next i - Case vbObject - For i = Index To GetCount - If VarType(pItems(i)) = vt AndAlso ObjPtr(pItems(i)) = ObjPtr(Value) Then Return i + pBaseIndex - Next i - Case Else - For i = Index To GetCount - If VarType(pItems(i)) = vt AndAlso pItems(i) = Value Then Return i + pBaseIndex - Next i - End Select - Return -1 - End Function - - [ Description ("Returns the last index of a particular item. Returns -1 if the item isn't in the list.") ] - Public Function LastIndexOf(ByRef Value As Variant, Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) As Long Implements IArrayList.LastIndexOf - If IsMissing(Index) Then Index = pIndex + pBaseIndex - 1 - Index = CLng(Index - pBaseIndex) - If IsMissing(GetCount) Then GetCount = Index + 1 - If Index >= pIndex Or GetCount > Index + 1 Then Err.Raise 9 - GetCount = Index - (GetCount - 1) - If pIndex = 0 Then Return -1 - Dim i As Long, vt As VbVarType = VarType(Value) - Select Case vt - Case vbNull - For i = Index To GetCount Step -1 - If IsNull(pItems(i)) Then Return i + pBaseIndex - Next i - Case vbObject - For i = Index To GetCount Step -1 - If VarType(pItems(i)) = vt AndAlso ObjPtr(pItems(i)) = ObjPtr(Value) Then Return i + pBaseIndex - Next i - Case Else - For i = Index To GetCount Step -1 - If VarType(pItems(i)) = vt AndAlso pItems(i) = Value Then Return i + pBaseIndex - Next i - End Select - Return -1 - End Function - - [ Description ("Inserts value into the list at position Index. Index must be non-negative and less than or equal to the number of elements in the list. If Index equals the number of items in the list, then value is appended to the end.") ] - Public Sub Insert(ByVal Index As Long, Value As Variant) Implements IArrayList.Insert - ReserveSpaceForInsert Index - pBaseIndex, 1 - If IsObject(Value) Then Set pItems(Index - pBaseIndex) = Value Else pItems(Index - pBaseIndex) = Value - pIndex += 1 - pVersion += 1 - End Sub - - [ Description ("Removes an item from the list.") ] - Public Sub Remove(Value As Variant) Implements IArrayList.Remove - Dim Index As Long = IndexOf(Value) - If Index >= pBaseIndex Then RemoveAt Index - End Sub - - [ Description ("Removes the item at Index position.") ] - Public Sub RemoveAt(ByVal Index As Long) Implements IArrayList.RemoveAt - Index = Index - pBaseIndex - If Index < 0 Or Index >= pIndex Then Err.Raise 9 - pItems(Index) = Empty - If Index < pIndex - 1 Then VBA.vbaCopyBytes (pIndex - Index - 1) * VARIANT_SIZE, VarPtr(pItems(Index)), VarPtr(pItems(Index + 1)) - VBA.PutMem2 VarPtr(pItems(pIndex - 1)), vbEmpty - pIndex -= 1 - pVersion += 1 - End Sub - - [ Description ("Removes a specified range of elements from the ArrayList, starting from a specified index. " & vbCrLf & _ - "### Parameters" & vbCrLf & _ - "`Index` (Type: Long): The starting index of the range to be removed. " & vbCrLf & _ - "`GetCount` (Type: Long): The number of elements to be removed starting from the index. " & vbCrLf & _ - "### Usage Example" & vbCrLf & _ - "```vb" & vbCrLf & _ - " ' Example Usage" & vbCrLf & _ - " Dim myArrayList As New ArrayList" & vbCrLf & _ - " ' (Assuming elements are present in the list)" & vbCrLf & _ - " myArrayList.RemoveRange 2, 3 ' Removes 3 elements starting from the 3rd index." & vbCrLf & _ - "```" & vbCrLf & _ - "### Notes" & vbCrLf & _ - "- If the index is less than 0, if the count is less than 0, or if the count exceeds the available range to be removed, an error with code 9 is raised. " & vbCrLf & _ - "- The elements within the range to be removed are set to `Empty`. " & vbCrLf & _ - "- Following removal, the elements after the specified range are shifted to fill the removed space. " & vbCrLf & _ - "- Memory is zeroed for the elements at the end of the ArrayList after the removal. " & vbCrLf & _ - "- The internal version of the ArrayList is updated after removal.") ] - Public Sub RemoveRange(ByVal Index As Long, ByVal GetCount As Long) Implements IArrayList.RemoveRange - Dim i As Long - Index = Index - pBaseIndex - If Index < 0 Or GetCount < 0 Or (pIndex - Index < GetCount) Then Err.Raise 9 - For i = 0 To GetCount - 1 - pItems(Index + i) = Empty - Next i - If Index < pIndex - 1 Then VBA.vbaCopyBytes (pIndex - Index - GetCount) * VARIANT_SIZE, VarPtr(pItems(Index)), VarPtr(pItems(Index + GetCount)) - ZeroMemory VarPtr(pItems(pIndex - GetCount)), GetCount * VARIANT_SIZE - pIndex -= GetCount - pVersion += 1 - End Sub - - Public Sub Reverse(Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) Implements IArrayList.Reverse - If IsMissing(Index) Then Index = pBaseIndex - Index = CLng(Index) - pBaseIndex - If IsMissing(GetCount) Then GetCount = pIndex - Index - If Index < 0 Or GetCount < 0 Or (pIndex - Index < GetCount) Then Err.Raise 9 - Dim i As Long, p0 As LongPtr = VarPtr(pItems(0)), iMax As Long = GetCount \ 2 - For i = 0 To iMax - VSwap p0 + CLngPtr(Index + i) * VARIANT_SIZE, p0 + CLngPtr(Index + (GetCount - 1) - i) * VARIANT_SIZE - Next i - pVersion += 1 - End Sub - - Public Function ToArray() As Variant() Implements IArrayList.ToArray - Dim t() As Variant - If pIndex = 0 Then Return Array() - ReDim t(pBaseIndex To pIndex + pBaseIndex - 1) - VariantArrayClone VarPtr(t(pBaseIndex)), VarPtr(pItems(0)), pIndex - ReassignArrayTo ToArray, t - End Function - - Public Function ToString(Optional TextQualifier As String = """", Optional ByVal UseNullAsEmpty As Boolean = True, Optional ByVal UnquotedKeysAllowed As Boolean = False) As String Implements IArrayList.ToString - Return CommonModule.Stringify(Me, TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) - End Function - - Public Sub AddRange(Target As Variant) Implements IArrayList.AddRange - InsertRange pIndex + pBaseIndex, Target - End Sub - - Public Sub InsertRange(ByVal Index As Long, Target As Variant) Implements IArrayList.InsertRange - Dim v As Variant, GetCount As Long - Index -= pBaseIndex - Select Case VarType(Target) - Case vbArray + vbVariant - GetCount = (UBound(Target) - LBound(Target)) + 1 - ReserveSpaceForInsert Index, GetCount - VariantArrayClone VarPtr(pItems(Index)), VarPtr(Target(LBound(Target))), GetCount - pIndex += GetCount - pVersion += 1 - Exit Sub - Case vbObject - GetCount = Target.Count - If TypeOf Target Is IListRange Then - InsertListTo Index, GetCount, Target - pIndex += GetCount - pVersion += 1 - Exit Sub - End If - Case Else - If Not IsArray(Target) Then Err.Raise 13 - GetCount = (UBound(Target) - LBound(Target)) + 1 - End Select - ReserveSpaceForInsert Index, GetCount - For Each v In Target - If IsObject(v) Then Set pItems(Index) = v Else pItems(Index) = v - Index += 1 - Next v - pIndex += GetCount - pVersion += 1 - End Sub - - Public Function GetRange(ByVal Index As Long, ByVal GetCount As Long) As IListRange Implements IArrayList.GetRange - If Index < pBaseIndex Or GetCount < 0 Or pIndex - (Index - pBaseIndex) < GetCount Then Err.Raise 9 - Dim r As New ListRange - Set GetRange = r.Bind(Me, Index, GetCount) - End Function - - Public Sub SetRange(ByVal Index As Long, Target As Variant) Implements IArrayList.SetRange - Dim v As Variant, GetCount As Long - Index -= pBaseIndex - Select Case VarType(Target) - Case vbArray + vbVariant - GetCount = (UBound(Target) - LBound(Target)) + 1 - If Index < 0 Or Index > pIndex - GetCount Then Err.Raise 9 - VariantArrayClone VarPtr(pItems(Index)), VarPtr(Target(LBound(Target))), GetCount - pVersion += 1 - Exit Sub - Case vbObject - GetCount = Target.Count - If Index < 0 Or Index > pIndex - GetCount Then Err.Raise 9 - If TypeOf Target Is IListRange Then - VariantArrayClone VarPtr(pItems(Index)), Target.GetAddressOfItemAt(0), GetCount - pVersion += 1 - End If - Case Else - If Not IsArray(Target) Then Err.Raise 13 - GetCount = (UBound(Target) - LBound(Target)) + 1 - If Index < 0 Or Index > pIndex - GetCount Then Err.Raise 9 - End Select - For Each v In Target - If IsObject(v) Then Set pItems(Index) = v Else pItems(Index) = v - Index += 1 - Next v - pVersion += 1 - End Sub - - /* [ CompilerOptions ("+llvm,+optimize") ] */ - [ ArrayBoundsChecks (False) ] - [ IntegerOverflowChecks (False) ] - Public Sub Sort(Optional ByVal Index As Variant, Optional ByVal GetCount As Variant, Optional Comparer As IComparer = Nothing) Implements IArrayList.Sort - If IsMissing(Index) Then Index = pBaseIndex - Index -= pBaseIndex - If IsMissing(GetCount) Then GetCount = pIndex - Index - If Comparer IsNot Nothing Then - QuickSort CLng(Index), Index + GetCount - 1, Comparer - Else - QuickSortV2 CLng(Index), Index + GetCount - 1 - End If - pVersion += 1 - End Sub - - /* [ CompilerOptions ("+llvm,+optimize") ] */ - [ ArrayBoundsChecks (False) ] - [ IntegerOverflowChecks (False) ] - [ Description ("Searches a section of a sorted list. Returns the index of the given value in the list. If not found, returns a negative integer. Use the bitwise operator (Not) to get the index of the first element larger than this one, if any.") ] - Public Function BinarySearch(ByVal Index As Long, ByVal GetCount As Long, Value As Variant, Optional ByRef Comparer As IComparer = Nothing) As Long Implements IArrayList.BinarySearch - Dim lo As Long, hi As Long, i As Long - Index -= pBaseIndex - lo = Index - hi = Index + GetCount - 1 - If Comparer IsNot Nothing Then - Do While (lo <= hi) - i = lo + ((hi - lo) \ 2) - Select Case Comparer.Compare(pItems(i), Value) - Case 0: Return i + pBaseIndex - Case Is < 0: lo = i + 1 - Case Else: hi = i - 1 - End Select - Loop - Else - Do While (lo <= hi) - i = lo + ((hi - lo) \ 2) - Select Case pItems(i) - Case Value: Return i + pBaseIndex - Case Is < Value: lo = i + 1 - Case Else: hi = i - 1 - End Select - Loop - End If - Return Not (lo + pBaseIndex) - End Function - - #Region "HIDDEN METHODS IN MSCORLIB" - [ Hidden ] - Public Function IndexOf_2(ByRef Value As Variant, ByVal Index As Long, ByVal GetCount As Long) As Long: Return IndexOf(Value, Index, GetCount): End Function - [ Hidden ] - Public Function IndexOf_3(ByRef Value As Variant) As Long: Return IndexOf(Value, pBaseIndex): End Function - [ Hidden ] - Public Sub Sort_2(ByRef Comparer As IComparer): Sort pBaseIndex, , Comparer: End Sub - [ Hidden ] - Public Function BinarySearch_2(ByRef Value As Variant) As Long: Return BinarySearch(pBaseIndex, pIndex, Value): End Function - [ Hidden ] - Public Function BinarySearch_3(ByRef Value As Variant, ByRef Comparer As IComparer) As Long: Return BinarySearch(pBaseIndex, pIndex, Value, Comparer): End Function - [ Hidden ] - Public Function LastIndexOf_2(ByRef Value As Variant, ByVal Index As Long) As Long: Return LastIndexOf(Value, Index, Index + 1): End Function - [ Hidden ] - Public Function LastIndexOf_3(ByRef Value As Variant, ByVal Index As Long, ByVal GetCount As Long) As Long: Return LastIndexOf(Value, Index, GetCount): End Function - #End Region - - #Region "PRIVATE METHODS" - Private Sub Class_Terminate() - On Error Resume Next - DoEvents - Erase pItems - On Error GoTo 0 - End Sub - - Private Function C2IArrayList(Value As Variant) As IArrayList: Return Value: End Function - - Private Function C2IListRange(Value As Variant) As IListRange: Return Value: End Function - - Friend Function GetAddressOfItemAt(Index As Long) As LongPtr Implements IArrayList.GetAddressOfItemAt: Return VarPtr(pItems(Index)): End Function - - #If Win64 Then - Private Type UDTVariantB - bytes(0 To 23) As Byte - End Type - #Else - Private Type UDTVariantB - bytes(0 To 15) As Byte - End Type - #End If - - Private Sub VSwap(ByRef A As UDTVariantB, ByRef B As UDTVariantB) - Static v As UDTVariantB - LSet v = A - LSet A = B - LSet B = v - End Sub - - /* [ CompilerOptions ("+llvm,+optimize") ] */ - [ ArrayBoundsChecks (False) ] - [ IntegerOverflowChecks (False) ] - Private Sub Swap(ByRef A As Variant, ByRef B As Variant) - Dim v As Variant - If IsObject(A) Then Set v = A Else v = A - If IsObject(B) Then Set A = B Else A = B - If IsObject(v) Then Set B = v Else B = v - End Sub - - /* [ CompilerOptions ("+llvm,+optimize") ] */ - [ ArrayBoundsChecks (False) ] - [ IntegerOverflowChecks (False) ] - Private Sub Assign(ByRef Target As Variant, ByRef Value As Variant) - If IsObject(Value) Then Set Target = Value Else Target = Value - End Sub - - Private Sub GrowCapacity(ByVal Increment As Long) - If pIndex + Increment > UBound(pItems) Then - If (UBound(pItems) * 2) + 2 >= pIndex + Increment Then - ReDim Preserve pItems(LBound(pItems) To (UBound(pItems) * 2) + 2) - Else - ReDim Preserve pItems(LBound(pItems) To pIndex + Increment) - End If - End If - End Sub - - Private Sub ReserveSpaceForInsertOfOneAtZero() - Dim ub As Long = UBound(pItems), lb As Long = LBound(pItems) - If lb < 0 Then - PutMem4 ArrPtr(pItems) + SAFEARRAY_LLBOUND_OFFSET, lb + 1 - Else - If pIndex + 30 > ub Then - ReDim Preserve pItems(-30& To (ub * 2) + 2) - Else - PutMem4 ArrPtr(pItems) + SAFEARRAY_LLBOUND_OFFSET, -30& - End If - lb = LBound(pItems) - MemMoveEx VarPtr(pItems(1)), VarPtr(pItems(lb)), pIndex * VARIANT_SIZE - ZeroMemory VarPtr(pItems(lb)), (Abs(lb) + 1) * VARIANT_SIZE - End If - End Sub - - Private Sub ReserveSpaceForInsert(ByVal Index As Long, ByVal GetCount As Long) - If Index = 0 AndAlso GetCount = 1 AndAlso pIndex > 0 Then - ReserveSpaceForInsertOfOneAtZero - Exit Sub - End If - If pIndex + GetCount > UBound(pItems) Then GrowCapacity GetCount - #If Win64 Then - RtlMoveMemory VarPtr(pItems(Index + GetCount)), VarPtr(pItems(Index)), (pIndex - Index) * VARIANT_SIZE - #Else - MemMoveEx VarPtr(pItems(Index + GetCount)), VarPtr(pItems(Index)), (pIndex - Index) * VARIANT_SIZE - #End If - If GetCount = 1 Then - VBA.PutMem2 VarPtr(pItems(Index)), vbEmpty - Else - ZeroMemory VarPtr(pItems(Index)), GetCount * VARIANT_SIZE - End If - End Sub - - Private Function IsContainedInMemoryRange(TargetList As IListRange, Optional ByVal Index As Long = 0, Optional ByVal GetCount As Variant) As Boolean - If IsMissing(GetCount) Then GetCount = pIndex - Index - If GetCount = 0 Then Return False - Return (TargetList.GetAddressOfItemAt(0) <= VarPtr(pItems(Index + GetCount - 1)) _ - And TargetList.GetAddressOfItemAt(TargetList.Count - 1) >= VarPtr(pItems(Index))) - End Function - - Private Sub InsertListTo(ByVal Index As Long, ByVal GetCount As Long, ByVal Target As IListRange) - Dim pv0 As LongPtr, pv0base As LongPtr, t() As Variant, isContained As Boolean - If GetCount <= 0 Then Exit Sub - pv0 = Target.GetAddressOfItemAt(0) - pv0base = VarPtr(pItems(0)) - If IsContainedInMemoryRange(Target, Index) Then - t = Target.ToArray() - pv0 = VarPtr(t(0)) - Else - isContained = IsContainedInMemoryRange(Target) - End If - GrowCapacity GetCount - If Index < pIndex Then - ' Move memory `Target.Count` positions to the right, from `Index` position - MemMoveEx VarPtr(pItems(Index + GetCount)), VarPtr(pItems(Index)), (pIndex - Index) * VARIANT_SIZE - ' SafeArrayCopyData releases any resources in destination array and those, if present, are - ' just copied to the right without increasing reference count so, we clear it beforehand to prevent - ' SafeArrayCopyData to release those resources. - ZeroMemory VarPtr(pItems(Index)), GetCount * VARIANT_SIZE - End If - If VarPtr(pItems(0)) <> pv0base And isContained Then - ' When `Target` derived from an array range contained within this list and, due to `Redim Preserve` from - ' `GrowCapacity` above, the array may get reallocated to a different memory region, we've to update the pointer. - pv0 = VarPtr(pItems(0)) + (pv0 - pv0base) - End If - ' Finally, insert (copy) all items in `Target` list to the region we just cleared for them. - VariantArrayClone VarPtr(pItems(Index)), pv0, GetCount - End Sub - - Private Sub QuickSort(l As Long, r As Long, ByRef Comparer As IComparer) - Dim p As Variant, l0 As Long, r0 As Long - l0 = l: r0 = r - Assign p, pItems((l + r) \ 2) - Do While (l0 <= r0) - Comparer.Compare pItems(l0), p - Do While (Comparer.Compare(pItems(l0), p) < 0 And l0 < r): l0 += 1: Loop - Do While (Comparer.Compare(p, pItems(r0)) < 0 And r0 > l): r0 -= 1: Loop - If (l0 <= r0) Then - VSwap VarPtr(pItems(l0)), VarPtr(pItems(r0)) - l0 += 1 - r0 -= 1 - End If - Loop - If (l < r0) Then QuickSort l, r0, Comparer - If (l0 < r) Then QuickSort l0, r, Comparer - End Sub - - Private Sub QuickSortV2(l As Long, r As Long) - Dim p As Variant, l0 As Long, r0 As Long - l0 = l: r0 = r - Assign p, pItems((l + r) \ 2) - Do While (l0 <= r0) - Do While (pItems(l0) < p And l0 < r): l0 += 1: Loop - Do While (p < pItems(r0) And r0 > l): r0 -= 1: Loop - If (l0 <= r0) Then - VSwap VarPtr(pItems(l0)), VarPtr(pItems(r0)) - l0 += 1 - r0 -= 1 - End If - Loop - If (l < r0) Then QuickSortV2 l, r0 - If (l0 < r) Then QuickSortV2 l0, r - End Sub - - Friend Sub CloneTo(ByVal Target As IArrayList, Source As IArrayList, ByVal Index As Long, ByVal GetCount As Long) Implements IArrayList.CloneTo - pVersion = Source.Version - Capacity = GetCount - VariantArrayClone VarPtr(pItems(0)), Source.GetAddressOfItemAt(Index), GetCount - pIndex = GetCount - End Sub - #End Region - -End Class + +[ ClassId ("E88D5510-C8E5-433D-8DA5-712D8586E0C9") ] +[ COMCreatable (True) ] +Public Class ArrayList + Implements IArrayList + Implements ICloneable + Implements IArray + + Private pItems() As Variant + Private pIndex As Long + Private pVersion As Long + Private pBaseIndex As Long + + Public Sub New(Optional ByVal Capacity As Long = 2, Optional ByVal BaseIndex As Long = 0) + ReDim pItems(0 To Capacity - 1) + pBaseIndex = BaseIndex + End Sub + + [ DefaultMember ] + Public Property Get Item(ByVal Index As Long) As Variant Implements IArrayList.Item + If Index < pBaseIndex Or Index >= pIndex + pBaseIndex Then Err.Raise 9 + Return pItems(Index - pBaseIndex) + End Property + + Public Property Let Item(ByVal Index As Long, Value As Variant) Implements IArrayList.Item + If Index < pBaseIndex Or Index >= pIndex + pBaseIndex Then Err.Raise 9 + pItems(Index - pBaseIndex) = Value + pVersion += 1 + End Property + + Public Property Set Item(ByVal Index As Long, Value As Variant) Implements IArrayList.Item + If Index < pBaseIndex Or Index >= pIndex + pBaseIndex Then Err.Raise 9 + Set pItems(Index - pBaseIndex) = Value + pVersion += 1 + End Property + + Public Property Get Count() As Long Implements IArrayList.Count, IArray.Count: Return pIndex: End Property + + Public Property Let Count(ByVal Value As Long) + If Value < 0 Then Err.Raise 9 + If Value > pIndex Then GrowCapacity(Value - pIndex) + pIndex = Value + pVersion += 1 + End Property + + Public Property Get BaseIndex() As Long Implements IArrayList.BaseIndex, IArray.BaseIndex: Return pBaseIndex: End Property + + Public Property Let BaseIndex(Value As Long) Implements IArrayList.BaseIndex: pBaseIndex = Value: pVersion += 1: End Property + [ Hidden ] + Public Property Get Version() As Long Implements IArrayList.Version: Return pVersion: End Property + + Public Property Get Capacity() As Long Implements IArrayList.Capacity: Return UBound(pItems) + 1: End Property + + Public Property Let Capacity(Value As Long) Implements IArrayList.Capacity: ReDim Preserve pItems(LBound(pItems) To Value - 1): End Property + [ Hidden ] + Public Property Get IsFixedSize() As Boolean Implements IArrayList.IsFixedSize: Return False: End Property + [ Hidden ] + Public Property Get IsReadOnly() As Boolean Implements IArrayList.IsReadOnly: Return False: End Property + [ Hidden ] + Public Property Get IsSynchronized() As Boolean Implements IArrayList.IsSynchronized: Return False: End Property + [ Hidden ] + Public Property Get SyncRoot() As Variant Implements IArrayList.SyncRoot: Return Nothing: End Property + + [ Hidden ] + [ Description ("CAUTION: Limit usage only in For Each In .Items calls, do NOT assign the return value of .Items to another variable unless you know what you're doing.") ] + Public Function Items() As Variant() Implements IArrayList.Items + /* Returns a 0-based Variant Array pointing to the same memory as the internal array of this list + * without increasing the reference count of byref elements within the list. + * If you assign this array to a variable in your code, you must remove the reference + * before it goes out of scope to prevent double deallocation of byref values. + */ + Static sa As SAFEARRAY_1D + With sa + .cDims = 1 + .cbElements = VARIANT_SIZE + .fFeatures = FADF_VARIANT Or FADF_AUTO + .cLocks = 10 + .pvData = VarPtr(pItems(0)) + .rgsabound0.cElements = pIndex + End With + VBA.PutMemPtr VarPtrArr(Items), VarPtr(sa) + End Function + + [ Description ("Adds an item to the list. The return value is the position the new element was inserted in.") ] + Public Function Add(Value As Variant) As Long Implements IArrayList.Add + If pIndex > UBound(pItems) Then GrowCapacity 1 + If IsObject(Value) Then Set pItems(pIndex) = Value Else pItems(pIndex) = Value + Add = pIndex + pBaseIndex + pIndex += 1 + pVersion += 1 + End Function + + [ Description ("Removes all items from the list.") ] + Public Sub Clear() Implements IArrayList.Clear + Erase pItems + ReDim pItems(0 To 1) + pIndex = 0 + pVersion += 1 + End Sub + + [ Description ("Creates a shallow copy of this ArrayList.") ] + Public Function Clone() As Variant Implements ICloneable.Clone + Dim Target As ArrayList + Set Target = New ArrayList(BaseIndex:=pBaseIndex) + C2IArrayList(Target).CloneTo Target, C2IArrayList(Me), 0, pIndex + Return Target + End Function + + [ Description ("Returns whether the list contains a particular item.") ] + Public Function Contains(Value As Variant) As Boolean Implements IArrayList.Contains + Dim i As Long, vt As VbVarType = VarType(Value) + Select Case vt + Case vbNull + For i = 0 To pIndex - 1 + If IsNull(pItems(i)) Then Return True + Next i + Case vbObject + For i = 0 To pIndex - 1 + If VarType(pItems(i)) = vt AndAlso ObjPtr(pItems(i)) = ObjPtr(Value) Then Return True + Next i + Case Else + For i = 0 To pIndex - 1 + If VarType(pItems(i)) = vt AndAlso pItems(i) = Value Then Return True + Next i + End Select + End Function + + [ Description ("Copies this ArrayList to another array at specified index, the other array must be of a compatible array type but not necessarily the same type. It also accepts other lists implementing IListRange as target.") ] + Public Sub CopyTo(Target As Variant, Index As Long) Implements IArrayList.CopyTo + Select Case VarType(Target) + Case vbObject + If TypeOf Target Is IListRange Then + C2IListRange(Target).SetRange Index, Me + Else + Err.Raise 13 + End If + Case vbArray + vbVariant + If Index < 0 Or Index > UBound(Target) Then Err.Raise 9 + If UBound(Target) - Index < pIndex Then Err.Raise 6 + VariantArrayClone VarPtr(Target(Index)), VarPtr(pItems(0)), pIndex + Case Else + If Not IsArray(Target) Then Err.Raise 13 + If Index < 0 Or Index > UBound(Target) Then Err.Raise 9 + If UBound(Target) - Index < pIndex Then Err.Raise 6 + Dim i As Long + For i = 0 To pIndex - 1 + Assign Target(Index + i), pItems(i) + Next i + End Select + End Sub + + [ Enumerator ] + [ Description ("When using this enumerator for more advanced usage other than regular For Each usage, Index is always 0-based regardless of the current BaseIndex value in this ArrayList.") ] + Public Function GetEnumerator(Optional ByVal Index As Long = 0, Optional ByVal GetCount As Variant, Optional ByVal GetStep As Long = 1, Optional ByRef ThisEnumerator As IEnumerator) As stdole.IUnknown Implements IArrayList.GetEnumerator + Static mEnumerator As Enumerator, mEnumeratorB As Enumerator, mVer As Long, mVerB As Long + If IsMissing(GetCount) Then GetCount = pIndex - Index + If GetCount > 0 Then + If mEnumerator Is Nothing Then + Set mEnumerator = New Enumerator(pItems, Index, GetCount, GetStep, ThisEnumerator) + mVer = pVersion + Else + If pVersion <> mVer Then + mEnumerator.Bind pItems, Index, GetCount, GetStep + mVer = pVersion + Else + If Not mEnumerator.IsAvailable Then + If mEnumeratorB Is Nothing Then + Set mEnumeratorB = New Enumerator(pItems, Index, GetCount, GetStep, ThisEnumerator) + mVerB = pVersion + ElseIf pVersion <> mVerB Then + mEnumeratorB.Bind pItems, Index, GetCount, GetStep + mVerB = pVersion + Else + ResetEnumerator(mEnumeratorB) + End If + Set ThisEnumerator = mEnumeratorB + Return mEnumeratorB + Else + ResetEnumerator(mEnumerator) + End If + End If + End If + Set ThisEnumerator = mEnumerator + Return mEnumerator + End If + End Function + + [ Description ("Returns the index of a particular item. Returns -1 if the item isn't in the list.") ] + Public Function IndexOf(Value As Variant, Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) As Long Implements IArrayList.IndexOf + If IsMissing(Index) Then Index = pBaseIndex + Index = CLng(Index - pBaseIndex) + If IsMissing(GetCount) Then GetCount = pIndex - Index + If Index > pIndex Or GetCount < 0 Or Index > pIndex - GetCount Then Err.Raise 9 + GetCount = Index + GetCount - 1 + If pIndex = 0 Then Return -1 + Dim i As Long, vt As VbVarType = VarType(Value) + Select Case vt + Case vbNull + For i = Index To GetCount + If IsNull(pItems(i)) Then Return i + pBaseIndex + Next i + Case vbObject + For i = Index To GetCount + If VarType(pItems(i)) = vt AndAlso ObjPtr(pItems(i)) = ObjPtr(Value) Then Return i + pBaseIndex + Next i + Case Else + For i = Index To GetCount + If VarType(pItems(i)) = vt AndAlso pItems(i) = Value Then Return i + pBaseIndex + Next i + End Select + Return -1 + End Function + + [ Description ("Returns the last index of a particular item. Returns -1 if the item isn't in the list.") ] + Public Function LastIndexOf(ByRef Value As Variant, Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) As Long Implements IArrayList.LastIndexOf + If IsMissing(Index) Then Index = pIndex + pBaseIndex - 1 + Index = CLng(Index - pBaseIndex) + If IsMissing(GetCount) Then GetCount = Index + 1 + If Index >= pIndex Or GetCount > Index + 1 Then Err.Raise 9 + GetCount = Index - (GetCount - 1) + If pIndex = 0 Then Return -1 + Dim i As Long, vt As VbVarType = VarType(Value) + Select Case vt + Case vbNull + For i = Index To GetCount Step -1 + If IsNull(pItems(i)) Then Return i + pBaseIndex + Next i + Case vbObject + For i = Index To GetCount Step -1 + If VarType(pItems(i)) = vt AndAlso ObjPtr(pItems(i)) = ObjPtr(Value) Then Return i + pBaseIndex + Next i + Case Else + For i = Index To GetCount Step -1 + If VarType(pItems(i)) = vt AndAlso pItems(i) = Value Then Return i + pBaseIndex + Next i + End Select + Return -1 + End Function + + [ Description ("Inserts value into the list at position Index. Index must be non-negative and less than or equal to the number of elements in the list. If Index equals the number of items in the list, then value is appended to the end.") ] + Public Sub Insert(ByVal Index As Long, Value As Variant) Implements IArrayList.Insert + ReserveSpaceForInsert Index - pBaseIndex, 1 + If IsObject(Value) Then Set pItems(Index - pBaseIndex) = Value Else pItems(Index - pBaseIndex) = Value + pIndex += 1 + pVersion += 1 + End Sub + + [ Description ("Removes an item from the list.") ] + Public Sub Remove(Value As Variant) Implements IArrayList.Remove + Dim Index As Long = IndexOf(Value) + If Index >= pBaseIndex Then RemoveAt Index + End Sub + + [ Description ("Removes the item at Index position.") ] + Public Sub RemoveAt(ByVal Index As Long) Implements IArrayList.RemoveAt + Index = Index - pBaseIndex + If Index < 0 Or Index >= pIndex Then Err.Raise 9 + pItems(Index) = Empty + If Index < pIndex - 1 Then VBA.vbaCopyBytes (pIndex - Index - 1) * VARIANT_SIZE, VarPtr(pItems(Index)), VarPtr(pItems(Index + 1)) + VBA.PutMem2 VarPtr(pItems(pIndex - 1)), vbEmpty + pIndex -= 1 + pVersion += 1 + End Sub + + [ Description ("Removes a specified range of elements from the ArrayList, starting from a specified index. " & vbCrLf & _ + "### Parameters" & vbCrLf & _ + "`Index` (Type: Long): The starting index of the range to be removed. " & vbCrLf & _ + "`GetCount` (Type: Long): The number of elements to be removed starting from the index. " & vbCrLf & _ + "### Usage Example" & vbCrLf & _ + "```vb" & vbCrLf & _ + " ' Example Usage" & vbCrLf & _ + " Dim myArrayList As New ArrayList" & vbCrLf & _ + " ' (Assuming elements are present in the list)" & vbCrLf & _ + " myArrayList.RemoveRange 2, 3 ' Removes 3 elements starting from the 3rd index." & vbCrLf & _ + "```" & vbCrLf & _ + "### Notes" & vbCrLf & _ + "- If the index is less than 0, if the count is less than 0, or if the count exceeds the available range to be removed, an error with code 9 is raised. " & vbCrLf & _ + "- The elements within the range to be removed are set to `Empty`. " & vbCrLf & _ + "- Following removal, the elements after the specified range are shifted to fill the removed space. " & vbCrLf & _ + "- Memory is zeroed for the elements at the end of the ArrayList after the removal. " & vbCrLf & _ + "- The internal version of the ArrayList is updated after removal.") ] + Public Sub RemoveRange(ByVal Index As Long, ByVal GetCount As Long) Implements IArrayList.RemoveRange + Dim i As Long + Index = Index - pBaseIndex + If Index < 0 Or GetCount < 0 Or (pIndex - Index < GetCount) Then Err.Raise 9 + For i = 0 To GetCount - 1 + pItems(Index + i) = Empty + Next i + If Index < pIndex - 1 Then VBA.vbaCopyBytes (pIndex - Index - GetCount) * VARIANT_SIZE, VarPtr(pItems(Index)), VarPtr(pItems(Index + GetCount)) + ZeroMemory VarPtr(pItems(pIndex - GetCount)), GetCount * VARIANT_SIZE + pIndex -= GetCount + pVersion += 1 + End Sub + + Public Sub Reverse(Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) Implements IArrayList.Reverse + If IsMissing(Index) Then Index = pBaseIndex + Index = CLng(Index) - pBaseIndex + If IsMissing(GetCount) Then GetCount = pIndex - Index + If Index < 0 Or GetCount < 0 Or (pIndex - Index < GetCount) Then Err.Raise 9 + Dim i As Long, p0 As LongPtr = VarPtr(pItems(0)), iMax As Long = GetCount \ 2 + For i = 0 To iMax + VSwap p0 + CLngPtr(Index + i) * VARIANT_SIZE, p0 + CLngPtr(Index + (GetCount - 1) - i) * VARIANT_SIZE + Next i + pVersion += 1 + End Sub + + [ Description ("Returns a shallow copy as a Variant() array. In those cases where you have to assign it to a Variant variable instead of a Variant() array. You can cast it to IArray before calling .ToArray() on it to prevent it from being assigned ByVal, which would cause the full array to be copied twice.") ] + Public Function ToArray() As Variant() Implements IArrayList.ToArray + Dim t() As Variant + If pIndex = 0 Then Return Array() + ReDim t(pBaseIndex To pIndex + pBaseIndex - 1) + VariantArrayClone VarPtr(t(pBaseIndex)), VarPtr(pItems(0)), pIndex + ReassignArrayTo ToArray, t + End Function + + Private Function IArray_ToArray() As Variant Implements IArray.ToArray + Dim t() As Variant + If pIndex = 0 Then Return Array() + ReDim t(pBaseIndex To pIndex + pBaseIndex - 1) + VariantArrayClone VarPtr(t(pBaseIndex)), VarPtr(pItems(0)), pIndex + ReassignArrayToVariant IArray_ToArray, t + End Function + + Public Function ToString(Optional TextQualifier As String = """", Optional ByVal UseNullAsEmpty As Boolean = True, Optional ByVal UnquotedKeysAllowed As Boolean = False) As String Implements IArrayList.ToString + Return CommonModule.Stringify(Me, TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) + End Function + + Public Sub AddRange(Target As Variant) Implements IArrayList.AddRange + InsertRange pIndex + pBaseIndex, Target + End Sub + + Public Sub InsertRange(ByVal Index As Long, Target As Variant) Implements IArrayList.InsertRange + Dim v As Variant, GetCount As Long + Index -= pBaseIndex + Select Case VarType(Target) + Case vbArray + vbVariant + GetCount = (UBound(Target) - LBound(Target)) + 1 + ReserveSpaceForInsert Index, GetCount + VariantArrayClone VarPtr(pItems(Index)), VarPtr(Target(LBound(Target))), GetCount + pIndex += GetCount + pVersion += 1 + Exit Sub + Case vbObject + GetCount = Target.Count + If TypeOf Target Is IListRange Then + InsertListTo Index, GetCount, Target + pIndex += GetCount + pVersion += 1 + Exit Sub + End If + Case Else + If Not IsArray(Target) Then Err.Raise 13 + GetCount = (UBound(Target) - LBound(Target)) + 1 + End Select + ReserveSpaceForInsert Index, GetCount + For Each v In Target + If IsObject(v) Then Set pItems(Index) = v Else pItems(Index) = v + Index += 1 + Next v + pIndex += GetCount + pVersion += 1 + End Sub + + Public Function GetRange(ByVal Index As Long, ByVal GetCount As Long) As IListRange Implements IArrayList.GetRange + If Index < pBaseIndex Or GetCount < 0 Or pIndex - (Index - pBaseIndex) < GetCount Then Err.Raise 9 + Dim r As New ListRange + Set GetRange = r.Bind(Me, Index, GetCount) + End Function + + Public Sub SetRange(ByVal Index As Long, Target As Variant) Implements IArrayList.SetRange + Dim v As Variant, GetCount As Long + Index -= pBaseIndex + Select Case VarType(Target) + Case vbArray + vbVariant + GetCount = (UBound(Target) - LBound(Target)) + 1 + If Index < 0 Or Index > pIndex - GetCount Then Err.Raise 9 + VariantArrayClone VarPtr(pItems(Index)), VarPtr(Target(LBound(Target))), GetCount + pVersion += 1 + Exit Sub + Case vbObject + GetCount = Target.Count + If Index < 0 Or Index > pIndex - GetCount Then Err.Raise 9 + If TypeOf Target Is IListRange Then + VariantArrayClone VarPtr(pItems(Index)), Target.GetAddressOfItemAt(0), GetCount + pVersion += 1 + End If + Case Else + If Not IsArray(Target) Then Err.Raise 13 + GetCount = (UBound(Target) - LBound(Target)) + 1 + If Index < 0 Or Index > pIndex - GetCount Then Err.Raise 9 + End Select + For Each v In Target + If IsObject(v) Then Set pItems(Index) = v Else pItems(Index) = v + Index += 1 + Next v + pVersion += 1 + End Sub + + /* [ CompilerOptions ("+llvm,+optimize") ] */ + [ ArrayBoundsChecks (False) ] + [ IntegerOverflowChecks (False) ] + Public Sub Sort(Optional ByVal Index As Variant, Optional ByVal GetCount As Variant, Optional Comparer As IComparer = Nothing) Implements IArrayList.Sort + If IsMissing(Index) Then Index = pBaseIndex + Index -= pBaseIndex + If IsMissing(GetCount) Then GetCount = pIndex - Index + If Comparer IsNot Nothing Then + QuickSort CLng(Index), Index + GetCount - 1, Comparer + Else + QuickSortV2 CLng(Index), Index + GetCount - 1 + End If + pVersion += 1 + End Sub + + /* [ CompilerOptions ("+llvm,+optimize") ] */ + [ ArrayBoundsChecks (False) ] + [ IntegerOverflowChecks (False) ] + [ Description ("Searches a section of a sorted list. Returns the index of the given value in the list. If not found, returns a negative integer. Use the bitwise operator (Not) to get the index of the first element larger than this one, if any.") ] + Public Function BinarySearch(ByVal Index As Long, ByVal GetCount As Long, Value As Variant, Optional ByRef Comparer As IComparer = Nothing) As Long Implements IArrayList.BinarySearch + Dim lo As Long, hi As Long, i As Long + Index -= pBaseIndex + lo = Index + hi = Index + GetCount - 1 + If Comparer IsNot Nothing Then + Do While (lo <= hi) + i = lo + ((hi - lo) \ 2) + Select Case Comparer.Compare(pItems(i), Value) + Case 0: Return i + pBaseIndex + Case Is < 0: lo = i + 1 + Case Else: hi = i - 1 + End Select + Loop + Else + Do While (lo <= hi) + i = lo + ((hi - lo) \ 2) + Select Case pItems(i) + Case Value: Return i + pBaseIndex + Case Is < Value: lo = i + 1 + Case Else: hi = i - 1 + End Select + Loop + End If + Return Not (lo + pBaseIndex) + End Function + + #Region "HIDDEN METHODS IN MSCORLIB" + [ Hidden ] + Public Function IndexOf_2(ByRef Value As Variant, ByVal Index As Long, ByVal GetCount As Long) As Long: Return IndexOf(Value, Index, GetCount): End Function + [ Hidden ] + Public Function IndexOf_3(ByRef Value As Variant) As Long: Return IndexOf(Value, pBaseIndex): End Function + [ Hidden ] + Public Sub Sort_2(ByRef Comparer As IComparer): Sort pBaseIndex, , Comparer: End Sub + [ Hidden ] + Public Function BinarySearch_2(ByRef Value As Variant) As Long: Return BinarySearch(pBaseIndex, pIndex, Value): End Function + [ Hidden ] + Public Function BinarySearch_3(ByRef Value As Variant, ByRef Comparer As IComparer) As Long: Return BinarySearch(pBaseIndex, pIndex, Value, Comparer): End Function + [ Hidden ] + Public Function LastIndexOf_2(ByRef Value As Variant, ByVal Index As Long) As Long: Return LastIndexOf(Value, Index, Index + 1): End Function + [ Hidden ] + Public Function LastIndexOf_3(ByRef Value As Variant, ByVal Index As Long, ByVal GetCount As Long) As Long: Return LastIndexOf(Value, Index, GetCount): End Function + #End Region + + #Region "PRIVATE METHODS" + Private Sub Class_Terminate() + On Error Resume Next + DoEvents + Erase pItems + On Error GoTo 0 + End Sub + + Friend Function GetAddressOfItemAt(Index As Long) As LongPtr Implements IArrayList.GetAddressOfItemAt, IArray.AddressOf: Return VarPtr(pItems(Index)): End Function + + #If Win64 Then + Private Type UDTVariantB + bytes(0 To 23) As Byte + End Type + #Else + Private Type UDTVariantB + bytes(0 To 15) As Byte + End Type + #End If + + Private Sub VSwap(ByRef A As UDTVariantB, ByRef B As UDTVariantB) + Static v As UDTVariantB + LSet v = A + LSet A = B + LSet B = v + End Sub + + /* [ CompilerOptions ("+llvm,+optimize") ] */ + [ ArrayBoundsChecks (False) ] + [ IntegerOverflowChecks (False) ] + Private Sub Swap(ByRef A As Variant, ByRef B As Variant) + Dim v As Variant + If IsObject(A) Then Set v = A Else v = A + If IsObject(B) Then Set A = B Else A = B + If IsObject(v) Then Set B = v Else B = v + End Sub + + /* [ CompilerOptions ("+llvm,+optimize") ] */ + [ ArrayBoundsChecks (False) ] + [ IntegerOverflowChecks (False) ] + Private Sub Assign(ByRef Target As Variant, ByRef Value As Variant) + If IsObject(Value) Then Set Target = Value Else Target = Value + End Sub + + Private Sub GrowCapacity(ByVal Increment As Long) + If pIndex + Increment > UBound(pItems) Then + If (UBound(pItems) * 2) + 2 >= pIndex + Increment Then + ReDim Preserve pItems(LBound(pItems) To (UBound(pItems) * 2) + 2) + Else + ReDim Preserve pItems(LBound(pItems) To pIndex + Increment) + End If + End If + End Sub + + Private Sub ReserveSpaceForInsertOfOneAtZero() + Dim ub As Long = UBound(pItems), lb As Long = LBound(pItems) + If lb < 0 Then + PutMem4 (Not Not pItems) + SAFEARRAY_OFFSETS.rgsaboundOffset + 4, lb + 1 + Else + If pIndex + 30 > ub Then + ReDim Preserve pItems(-30& To (ub * 2) + 2) + Else + PutMem4 (Not Not pItems) + SAFEARRAY_OFFSETS.rgsaboundOffset + 4, -30& + End If + lb = LBound(pItems) + MemMoveEx VarPtr(pItems(1)), VarPtr(pItems(lb)), pIndex * VARIANT_SIZE + ZeroMemory VarPtr(pItems(lb)), (Abs(lb) + 1) * VARIANT_SIZE + End If + End Sub + + Private Sub ReserveSpaceForInsert(ByVal Index As Long, ByVal GetCount As Long) + If Index = 0 AndAlso GetCount = 1 AndAlso pIndex > 0 Then + ReserveSpaceForInsertOfOneAtZero + Exit Sub + End If + If pIndex + GetCount > UBound(pItems) Then GrowCapacity GetCount + #If Win64 Then + RtlMoveMemory VarPtr(pItems(Index + GetCount)), VarPtr(pItems(Index)), (pIndex - Index) * VARIANT_SIZE + #Else + MemMoveEx VarPtr(pItems(Index + GetCount)), VarPtr(pItems(Index)), (pIndex - Index) * VARIANT_SIZE + #End If + If GetCount = 1 Then + VBA.PutMem2 VarPtr(pItems(Index)), vbEmpty + Else + ZeroMemory VarPtr(pItems(Index)), GetCount * VARIANT_SIZE + End If + End Sub + + Private Function IsContainedInMemoryRange(TargetList As IListRange, Optional ByVal Index As Long = 0, Optional ByVal GetCount As Variant) As Boolean + If IsMissing(GetCount) Then GetCount = pIndex - Index + If GetCount = 0 Then Return False + Return (TargetList.GetAddressOfItemAt(0) <= VarPtr(pItems(Index + GetCount - 1)) _ + And TargetList.GetAddressOfItemAt(TargetList.Count - 1) >= VarPtr(pItems(Index))) + End Function + + Private Sub InsertListTo(ByVal Index As Long, ByVal GetCount As Long, ByVal Target As IListRange) + Dim pv0 As LongPtr, pv0base As LongPtr, t() As Variant, isContained As Boolean + If GetCount <= 0 Then Exit Sub + pv0 = Target.GetAddressOfItemAt(0) + pv0base = VarPtr(pItems(0)) + If IsContainedInMemoryRange(Target, Index) Then + t = Target.ToArray() + pv0 = VarPtr(t(0)) + Else + isContained = IsContainedInMemoryRange(Target) + End If + GrowCapacity GetCount + If Index < pIndex Then + ' Move memory `Target.Count` positions to the right, from `Index` position + MemMoveEx VarPtr(pItems(Index + GetCount)), VarPtr(pItems(Index)), (pIndex - Index) * VARIANT_SIZE + ' SafeArrayCopyData releases any resources in destination array and those, if present, are + ' just copied to the right without increasing reference count so, we clear it beforehand to prevent + ' SafeArrayCopyData to release those resources. + ZeroMemory VarPtr(pItems(Index)), GetCount * VARIANT_SIZE + End If + If VarPtr(pItems(0)) <> pv0base And isContained Then + ' When `Target` derived from an array range contained within this list and, due to `Redim Preserve` from + ' `GrowCapacity` above, the array may get reallocated to a different memory region, we've to update the pointer. + pv0 = VarPtr(pItems(0)) + (pv0 - pv0base) + End If + ' Finally, insert (copy) all items in `Target` list to the region we just cleared for them. + VariantArrayClone VarPtr(pItems(Index)), pv0, GetCount + End Sub + + Private Sub QuickSort(l As Long, r As Long, ByRef Comparer As IComparer) + Dim p As Variant, l0 As Long, r0 As Long + l0 = l: r0 = r + Assign p, pItems((l + r) \ 2) + Do While (l0 <= r0) + Comparer.Compare pItems(l0), p + Do While (Comparer.Compare(pItems(l0), p) < 0 And l0 < r): l0 += 1: Loop + Do While (Comparer.Compare(p, pItems(r0)) < 0 And r0 > l): r0 -= 1: Loop + If (l0 <= r0) Then + VSwap VarPtr(pItems(l0)), VarPtr(pItems(r0)) + l0 += 1 + r0 -= 1 + End If + Loop + If (l < r0) Then QuickSort l, r0, Comparer + If (l0 < r) Then QuickSort l0, r, Comparer + End Sub + + Private Sub QuickSortV2(l As Long, r As Long) + Dim p As Variant, l0 As Long, r0 As Long + l0 = l: r0 = r + Assign p, pItems((l + r) \ 2) + Do While (l0 <= r0) + Do While (pItems(l0) < p And l0 < r): l0 += 1: Loop + Do While (p < pItems(r0) And r0 > l): r0 -= 1: Loop + If (l0 <= r0) Then + VSwap VarPtr(pItems(l0)), VarPtr(pItems(r0)) + l0 += 1 + r0 -= 1 + End If + Loop + If (l < r0) Then QuickSortV2 l, r0 + If (l0 < r) Then QuickSortV2 l0, r + End Sub + + Friend Sub CloneTo(ByVal Target As IArrayList, Source As IArrayList, ByVal Index As Long, ByVal GetCount As Long) Implements IArrayList.CloneTo + pVersion = Source.Version + Capacity = GetCount + VariantArrayClone VarPtr(pItems(0)), Source.GetAddressOfItemAt(Index), GetCount + pIndex = GetCount + End Sub + #End Region + +End Class diff --git a/ArrayListLib/Sources/Enumerator.twin b/ArrayListLib/Sources/Enumerator.twin index 15857fd..8a48c87 100644 --- a/ArrayListLib/Sources/Enumerator.twin +++ b/ArrayListLib/Sources/Enumerator.twin @@ -1,145 +1,156 @@ -[ InterfaceId ("00020404-0000-0000-C000-000000000046") ] -[ COMExtensible (True) ] -Public Interface IEnumVARIANT Extends stdole.IUnknown - Sub Next(ByVal celt As Long, ByRef rgvar As Variant, ByRef pceltFetched As Long) - Sub Skip(ByVal celt As Long) - Sub Reset() - Sub Clone(ByRef ppenum As IEnumVARIANT) -End Interface - -[ InterfaceId ("8E42D737-24C2-4D3F-8903-4B30E9383C69") ] -[ COMExtensible (True) ] -Public Interface IEnumerator Extends IEnumVARIANT - [ Description ("The Index of the current item being enumerated. If you manually change it, the next item being enumerated will be the one at the specified index.") ] - Property Get CurrentIndex() As Long - Property Let CurrentIndex(Value As Long) - [ Description ("Allows to change the iteration steps count and it's direction.") ] - Property Get CurrentStep() As Long - Property Let CurrentStep(Value As Long) - [ Description ("It's the size of the list, array, or section of it, which is being enumerated. Use with caution and only when enumerating a section of a bigger collection. This won't check for out of bounds.") ] - Property Get CurrentSize() As Long - Property Let CurrentSize(Value As Long) -End Interface - -[ ClassId ("5892CEA6-ADE3-4532-B478-1F6122F3537C") ] -[ COMCreatable (True) ] -Public Class Enumerator - Implements IEnumerator - - Private CIndex As Long - Private MaxValue As Long - Private Items() As Variant - Private CStep As Long - Private NStep As Long - Private IsEnumerating As Boolean - Private Const E_INVALIDARGS As Long = &H80070057 - Private Const S_OK As Long = 0 - Private Const S_FALSE As Long = 1 - - [ Description ("The Index of the current item being enumerated. If you manually change it, the next item being enumerated will be the one at the specified index.") ] - Public Property Get CurrentIndex() As Long Implements IEnumerator.CurrentIndex: CurrentIndex = CIndex: End Property - - Public Property Let CurrentIndex(Value As Long) Implements IEnumerator.CurrentIndex: CIndex = Value: NStep = 0: End Property - - [ Description ("Allows to change the iteration steps count and it's direction.") ] - Public Property Get CurrentStep() As Long Implements IEnumerator.CurrentStep: CurrentStep = CStep: End Property - - Public Property Let CurrentStep(Value As Long) Implements IEnumerator.CurrentStep: CStep = Value: NStep = CStep: End Property - - [ Description ("It's the size of the list, array, or section of it, which is being enumerated. Use with caution and only when enumerating a section of a bigger collection. This won't check for out of bounds.") ] - Public Property Get CurrentSize() As Long Implements IEnumerator.CurrentSize: CurrentSize = MaxValue: End Property - - Public Property Let CurrentSize(Value As Long) Implements IEnumerator.CurrentSize - MaxValue = Value - PutMem4 ArrPtr(Items) + SAFEARRAY_CELEMENTS_OFFSET, Value - End Property - - Public Property Get IsAvailable() As Boolean: IsAvailable = Not IsEnumerating: End Property - - Public Sub New() - End Sub - - Public Sub New(ByRef TargetArray() As Variant, Optional ByVal Index As Long = 0, Optional ByVal GetCount As Variant, Optional ByVal GetStep As Long = 1, Optional ByRef ThisEnumerator As IEnumerator) - If IsMissing(GetCount) Then GetCount = 1 + UBound(TargetArray) - Index - Bind TargetArray, Index, GetCount, GetStep - Set ThisEnumerator = Me - End Sub - - Public Sub Bind(ByRef TargetArray() As Variant, ByVal Index As Long, ByVal GetCount As Long, ByVal GetStep As Long) - Static sa As SAFEARRAY_1D - With sa - .cDims = 1 - .cbElements = VARIANT_SIZE - .fFeatures = FADF_VARIANT Or FADF_AUTO - .cLocks = 10 - .pvData = VarPtr(TargetArray(Index)) - .rgsabound0.cElements = GetCount - End With - VBA.PutMemPtr VarPtrArr(Items), VarPtr(sa) - CStep = GetStep - NStep = 0 - MaxValue = GetCount - If CStep < 0 Then - CIndex = GetCount - 1 - Else - CIndex = 0 - End If - End Sub - - [ Enumerator ] - Public Function GetEnumerator() As stdole.IUnknown - Return Me - End Function - - /* [ CompilerOptions ("+llvm,+optimize") ] */ - [ ArrayBoundsChecks (False) ] - [ IntegerOverflowChecks (False) ] - Private Sub Next(ByVal celt As Long, ByRef rgvar As Variant, ByRef pceltFetched As Long) Implements IEnumerator.Next - If VarPtr(rgvar) = 0 Or celt <> 1 Then - Err.ReturnHResult = E_INVALIDARGS - Else - CIndex += NStep - If CIndex < MaxValue And CIndex >= 0 Then - Assign rgvar, Items(CIndex) - NStep = CStep - If VarPtr(pceltFetched) <> 0 Then pceltFetched = 1 - Err.ReturnHResult = S_OK - Else - If VarPtr(pceltFetched) <> 0 Then pceltFetched = 0 - IsEnumerating = False - Err.ReturnHResult = S_FALSE - End If - End If - End Sub - - Private Sub Skip(ByVal celt As Long) Implements IEnumerator.Skip - CIndex += celt * CStep - If CIndex > MaxValue Then - CIndex = MaxValue + 1 - ElseIf CIndex < 0 Then - CIndex = -1 - End If - End Sub - - Private Sub Reset() Implements IEnumerator.Reset - CIndex = If(CStep < 0, MaxValue - 1, 0) - NStep = 0 - IsEnumerating = True - End Sub - - Private Sub Clone(ByRef ppenum As IEnumVARIANT) Implements IEnumerator.Clone - Set ppenum = New Enumerator(Items, 0, MaxValue, CStep) - End Sub - - /* [ CompilerOptions ("+llvm,+optimize") ] */ - [ IntegerOverflowChecks (False) ] - Private Sub Assign(ByRef Target As Variant, ByRef Value As Variant) - If IsObject(Value) Then Set Target = Value Else Target = Value - End Sub - - Private Sub Class_Terminate() - On Error Resume Next - If IsArrayInitialized(Items) Then PutMemPtr VarPtrArr(Items), vbNullPtr - On Error GoTo 0 - End Sub -End Class +[ InterfaceId ("00020404-0000-0000-C000-000000000046") ] +[ COMExtensible (True) ] +Public Interface IEnumVARIANT Extends stdole.IUnknown + Sub Next(ByVal celt As Long, ByRef rgvar As Variant, ByRef pceltFetched As Long) + Sub Skip(ByVal celt As Long) + Sub Reset() + Sub Clone(ByRef ppenum As IEnumVARIANT) +End Interface + +[ InterfaceId ("8E42D737-24C2-4D3F-8903-4B30E9383C69") ] +[ COMExtensible (True) ] +Public Interface IEnumerator Extends IEnumVARIANT + [ Description ("The Index of the current item being enumerated. If you manually change it, the next item being enumerated will be the one at the specified index.") ] + Property Get CurrentIndex() As Long + Property Let CurrentIndex(Value As Long) + [ Description ("Allows to change the iteration steps count and it's direction.") ] + Property Get CurrentStep() As Long + Property Let CurrentStep(Value As Long) + [ Description ("It's the size of the list, array, or section of it, which is being enumerated. Use with caution and only when enumerating a section of a bigger collection. This won't check for out of bounds.") ] + Property Get CurrentSize() As Long + Property Let CurrentSize(Value As Long) +End Interface + +[ ClassId ("5892CEA6-ADE3-4532-B478-1F6122F3537C") ] +[ COMCreatable (True) ] +Public Class Enumerator + Implements IEnumerator + + Private CIndex As Long + Private MaxValue As Long + Private VT As Integer + Private SizeVT As Long + Private FirstElementAddress As LongPtr + Private CStep As Long + Private NStep As Long + Private IsEnumerating As Boolean + Private Const E_INVALIDARGS As Long = &H80070057 + Private Const S_OK As Long = 0 + Private Const S_FALSE As Long = 1 + + #Region "PUBLIC PROPERTIES" + [ Description ("The Index of the current item being enumerated. If you manually change it, the next item being enumerated will be the one at the specified index.") ] + Public Property Get CurrentIndex() As Long Implements IEnumerator.CurrentIndex: CurrentIndex = CIndex: End Property + + Public Property Let CurrentIndex(Value As Long) Implements IEnumerator.CurrentIndex: CIndex = Value: NStep = 0: End Property + + [ Description ("Allows to change the iteration steps count and it's direction.") ] + Public Property Get CurrentStep() As Long Implements IEnumerator.CurrentStep: CurrentStep = CStep: End Property + + Public Property Let CurrentStep(Value As Long) Implements IEnumerator.CurrentStep: CStep = Value: NStep = CStep: End Property + + [ Description ("It's the size of the list, array, or section of it, which is being enumerated. Use with caution and only when enumerating a section of a bigger collection. This won't check for out of bounds.") ] + Public Property Get CurrentSize() As Long Implements IEnumerator.CurrentSize: CurrentSize = MaxValue: End Property + + Public Property Let CurrentSize(Value As Long) Implements IEnumerator.CurrentSize: MaxValue = Value: End Property + + Public Property Get IsAvailable() As Boolean: IsAvailable = Not IsEnumerating: End Property + #End Region + + Public Sub New(): End Sub + + Public Sub New(TargetArray As Variant, _ + Optional ByVal Index As Long = 0, _ + Optional ByVal Count As Variant, _ + Optional ByVal Step As Long = 1, _ + Optional ByRef ThisEnumerator As IEnumerator) + Set ThisEnumerator = Bind(TargetArray, Index, Count, Step) + End Sub + + [ Description ("Binds this enumerator to the provided array or any object implementing the IArray interface.") ] + Public Function Bind(TargetArray As Variant, _ + Optional ByVal Index As Long = 0, _ + Optional ByVal Count As Variant, _ + Optional ByVal Step As Long = 1) As Enumerator + If IsObject(TargetArray) AndAlso TypeOf TargetArray Is IArray Then + With C2IArray(TargetArray) + If Index <> 0 Then Index -= .BaseIndex + If IsMissing(Count) Then Count = .Count - Index + Return BindToAddress(.AddressOf(0), Index, Count, Step, vbVariant) + End With + ElseIf IsArray(TargetArray) Then + Dim descriptorAddress As LongPtr + If Index <> 0 Then Index -= LBound(TargetArray) + If IsMissing(Count) Then Count = 1 + (UBound(TargetArray) - LBound(TargetArray)) - Index + SafeArrayDescriptorAndVT VarPtr(TargetArray), descriptorAddress, VT + GetMemPtr descriptorAddress + SAFEARRAY_OFFSETS.pvDataOffset, FirstElementAddress + Return BindToAddress(FirstElementAddress, Index, Count, Step, VT) + End If + End Function + + Public Function BindToAddress(TargetAddress As LongPtr, _ + Optional ByVal Index As Long = 0, _ + Optional ByVal Count As Long = 0, _ + Optional ByVal Step As Long = 1, _ + Optional ByVal VType As VbVarType = vbVariant) As Enumerator + VT = VType + SizeOfVT VT, SizeVT + FirstElementAddress = TargetAddress + If Index > 0 Then FirstElementAddress += Index * SizeVT + CStep = Step + NStep = 0 + MaxValue = Count + CIndex = If(CStep < 0, MaxValue - 1, 0) + IsEnumerating = True + Return Me + End Function + + [ Enumerator ] + Public Function GetEnumerator() As stdole.IUnknown + Return Me + End Function + + /* [ CompilerOptions ("+llvm,+optimize") ] */ + [ ArrayBoundsChecks (False) ] + [ IntegerOverflowChecks (False) ] + Private Sub Next(ByVal celt As Long, ByRef rgvar As Variant, ByRef pceltFetched As Long) Implements IEnumerator.Next + If VarPtr(rgvar) = 0 Or celt <> 1 Then + Err.ReturnHResult = E_INVALIDARGS + Else + CIndex += NStep + If CIndex < MaxValue And CIndex >= 0 Then + PutMem2 VarPtr(rgvar), VT + VT_BYREF + PutMemPtr VarPtr(rgvar) + 8, FirstElementAddress + (CIndex * SizeVT) + NStep = CStep + If VarPtr(pceltFetched) <> 0 Then pceltFetched = 1 + Err.ReturnHResult = S_OK + Else + If VarPtr(pceltFetched) <> 0 Then pceltFetched = 0 + IsEnumerating = False + Err.ReturnHResult = S_FALSE + End If + End If + End Sub + + Private Sub Skip(ByVal celt As Long) Implements IEnumerator.Skip + CIndex += celt * CStep + If CIndex > MaxValue Then + CIndex = MaxValue + 1 + ElseIf CIndex < 0 Then + CIndex = -1 + End If + End Sub + + Private Sub Reset() Implements IEnumerator.Reset + CIndex = If(CStep < 0, MaxValue - 1, 0) + NStep = 0 + IsEnumerating = True + End Sub + + Private Sub Clone(ByRef ppenum As IEnumVARIANT) Implements IEnumerator.Clone + Dim e As New Enumerator + e.BindToAddress(FirstElementAddress, 0, MaxValue, CStep, VT) + Set ppenum = e + End Sub + +End Class diff --git a/ArrayListLib/Sources/IArrayList.twin b/ArrayListLib/Sources/IArrayList.twin index bb57ae0..95fc0fd 100644 --- a/ArrayListLib/Sources/IArrayList.twin +++ b/ArrayListLib/Sources/IArrayList.twin @@ -1,79 +1,91 @@ -[ InterfaceId ("8ABD76D4-42F5-4920-927A-BC766E00CE46") ] -[ Description ("Make a new object which is a copy of the object instanced. This object may be either deep copy or a shallow copy depending on the implementation of clone.") ] -Public Interface ICloneable - Function Clone() As Variant -End Interface - -[ InterfaceId ("F078EB73-3FA5-47F4-8003-520AEA1CE315") ] -Public Interface IEnumerable - [ Enumerator ] - Function GetEnumerator(Optional ByVal Index As Long = 0, Optional ByVal GetCount As Variant, Optional ByVal GetStep As Long = 1, Optional ByRef ThisEnumerator As Any) As stdole.IUnknown -End Interface - -[ InterfaceId ("B2E5C8F5-2847-450B-873B-F4BE7621F627") ] -[ Description ("Base interface for all collections") ] -Public Interface ICollection Extends IEnumerable - Sub CopyTo(Target As Variant, Index As Long) - Property Get Count() As Long - Property Get SyncRoot() As Variant - Property Get IsSynchronized() As Boolean -End Interface - -[ InterfaceId ("BC694131-C923-4813-9D34-C79C5E2F6980") ] -[ Description ("Base interface for all lists.") ] -Public Interface IList Extends ICollection - [ Description ("The Item property provides methods to read and edit entries in the List.") ] - Property Get Item(ByVal Index As Long) As Variant - Property Let Item(ByVal Index As Long, Value As Variant) - Property Set Item(ByVal Index As Long, Value As Variant) - [ Description ("Adds an item to the list. The return value is the position the new element was inserted in.") ] - Function Add(Value As Variant) As Long - [ Description ("Returns whether the list contains a particular item.") ] - Function Contains(Value As Variant) As Boolean - [ Description ("Removes all items from the list.") ] - Sub Clear() - Property Get IsReadOnly() As Boolean - Property Get IsFixedSize() As Boolean - [ Description ("Returns the index of a particular item. Returns -1 if the item isn't in the list.") ] - Function IndexOf(Value As Variant, Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) As Long - [ Description ("Inserts value into the list at position Index. Index must be non-negative and less than or equal to the number of elements in the list. If Index equals the number of items in the list, then value is appended to the end.") ] - Sub Insert(ByVal Index As Long, Value As Variant) - [ Description ("Removes an item from the list.") ] - Sub Remove(Value As Variant) - [ Description ("Removes the item at position index.") ] - Sub RemoveAt(ByVal Index As Long) -End Interface - -[ InterfaceId ("480A22F9-91B0-483A-8A33-11634FCF644A") ] -Public Interface IListRange Extends IList - Sub AddRange(Target As Variant) - Sub InsertRange(ByVal Index As Long, Target As Variant) - Function GetRange(ByVal Index As Long, ByVal GetCount As Long) As IListRange - [ Description ("Removes a range of elements from the list.") ] - Sub RemoveRange(ByVal Index As Long, ByVal GetCount As Long) - Sub SetRange(ByVal Index As Long, Target As Variant) - Function ToArray() As Variant() - Function ToString(Optional TextQualifier As String, Optional ByVal UseNullAsEmpty As Boolean, Optional ByVal UnquotedKeysAllowed As Boolean) As String - [ Description ("Sorts the elements in a section of this list. The sort compares the elements to each other using the given IComparer interface.") ] - Sub Sort(Optional ByVal Index As Variant, Optional ByVal GetCount As Variant, Optional ByRef Comparer As IComparer = Nothing) - Function BinarySearch(ByVal Index As Long, ByVal GetCount As Long, ByRef Value As Variant, Optional ByRef Comparer As IComparer = Nothing) As Long - [ Hidden ] - Function GetAddressOfItemAt(Index As Long) As LongPtr -End Interface - -[ InterfaceId ("1043D433-27BB-40F7-9255-50F4724FAB94") ] -Public Interface IArrayList Extends IListRange - Property Get BaseIndex() As Long - Property Let BaseIndex(Value As Long) - [ Hidden ] - Property Get Version() As Long - Property Get Capacity() As Long - Property Let Capacity(Value As Long) - [ Description ("CAUTION: Limit usage only in For Each In .Items calls, do NOT assign the return value of .Items to another variable unless you know what you're doing.") ] - [ Hidden ] - Function Items() As Variant() - [ Hidden ] - Sub CloneTo(ByVal Target As IArrayList, ByRef Source As IArrayList, ByVal Index As Long, ByVal GetCount As Long) - Function LastIndexOf(ByRef Value As Variant, Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) As Long - Sub Reverse(Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) -End Interface +[ InterfaceId ("8ABD76D4-42F5-4920-927A-BC766E00CE46") ] +[ Description ("Make a new object which is a copy of the object instanced. This object may be either deep copy or a shallow copy depending on the implementation of clone.") ] +Public Interface ICloneable + Function Clone() As Variant +End Interface + +[ InterfaceId ("F078EB73-3FA5-47F4-8003-520AEA1CE315") ] +Public Interface IEnumerable + [ Enumerator ] + Function GetEnumerator(Optional ByVal Index As Long = 0, Optional ByVal GetCount As Variant, Optional ByVal GetStep As Long = 1, Optional ByRef ThisEnumerator As Any) As stdole.IUnknown +End Interface + +[ InterfaceId ("B2E5C8F5-2847-450B-873B-F4BE7621F627") ] +[ Description ("Base interface for all collections") ] +Public Interface ICollection Extends IEnumerable + Sub CopyTo(Target As Variant, Index As Long) + Property Get Count() As Long + Property Get SyncRoot() As Variant + Property Get IsSynchronized() As Boolean +End Interface + +[ InterfaceId ("BC694131-C923-4813-9D34-C79C5E2F6980") ] +[ Description ("Base interface for all lists.") ] +Public Interface IList Extends ICollection + [ Description ("The Item property provides methods to read and edit entries in the List.") ] + Property Get Item(ByVal Index As Long) As Variant + Property Let Item(ByVal Index As Long, Value As Variant) + Property Set Item(ByVal Index As Long, Value As Variant) + [ Description ("Adds an item to the list. The return value is the position the new element was inserted in.") ] + Function Add(Value As Variant) As Long + [ Description ("Returns whether the list contains a particular item.") ] + Function Contains(Value As Variant) As Boolean + [ Description ("Removes all items from the list.") ] + Sub Clear() + Property Get IsReadOnly() As Boolean + Property Get IsFixedSize() As Boolean + [ Description ("Returns the index of a particular item. Returns -1 if the item isn't in the list.") ] + Function IndexOf(Value As Variant, Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) As Long + [ Description ("Inserts value into the list at position Index. Index must be non-negative and less than or equal to the number of elements in the list. If Index equals the number of items in the list, then value is appended to the end.") ] + Sub Insert(ByVal Index As Long, Value As Variant) + [ Description ("Removes an item from the list.") ] + Sub Remove(Value As Variant) + [ Description ("Removes the item at position index.") ] + Sub RemoveAt(ByVal Index As Long) +End Interface + +[ InterfaceId ("480A22F9-91B0-483A-8A33-11634FCF644A") ] +Public Interface IListRange Extends IList + Sub AddRange(Target As Variant) + Sub InsertRange(ByVal Index As Long, Target As Variant) + Function GetRange(ByVal Index As Long, ByVal GetCount As Long) As IListRange + [ Description ("Removes a range of elements from the list.") ] + Sub RemoveRange(ByVal Index As Long, ByVal GetCount As Long) + Sub SetRange(ByVal Index As Long, Target As Variant) + Function ToArray() As Variant() + Function ToString(Optional TextQualifier As String, Optional ByVal UseNullAsEmpty As Boolean, Optional ByVal UnquotedKeysAllowed As Boolean) As String + [ Description ("Sorts the elements in a section of this list. The sort compares the elements to each other using the given IComparer interface.") ] + Sub Sort(Optional ByVal Index As Variant, Optional ByVal GetCount As Variant, Optional ByRef Comparer As IComparer = Nothing) + Function BinarySearch(ByVal Index As Long, ByVal GetCount As Long, ByRef Value As Variant, Optional ByRef Comparer As IComparer = Nothing) As Long + [ Hidden ] + Function GetAddressOfItemAt(Index As Long) As LongPtr +End Interface + +[ InterfaceId ("1043D433-27BB-40F7-9255-50F4724FAB94") ] +Public Interface IArrayList Extends IListRange + Property Get BaseIndex() As Long + Property Let BaseIndex(Value As Long) + [ Hidden ] + Property Get Version() As Long + Property Get Capacity() As Long + Property Let Capacity(Value As Long) + [ Description ("CAUTION: Limit usage only in For Each In .Items calls, do NOT assign the return value of .Items to another variable unless you know what you're doing.") ] + [ Hidden ] + Function Items() As Variant() + [ Hidden ] + Sub CloneTo(ByVal Target As IArrayList, ByRef Source As IArrayList, ByVal Index As Long, ByVal GetCount As Long) + Function LastIndexOf(ByRef Value As Variant, Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) As Long + Sub Reverse(Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) +End Interface + +[ InterfaceId ("0E7AA3EE-2DFC-4BC7-8D38-CD2188C9D269") ] +[ Description ("Base interface for any collection type that could be accessed or iterated as a single dimension array of elements. " & vbcrlf & "Unlike ArrayList, it's not limited to Variant() types.") ] +Public Interface IArray Extends stdole.IDispatch + Property Get Count() As Long + [ Description ("Returns the N-based Index value, usually 0 or 1. Used to translate any provided Index value to the 0-based index equivalent.") ] + Property Get BaseIndex() As Long + [ Description ("Returns a shallow copy of all it's elements in a Variant variable.") ] + Function ToArray() As Variant + [ Description ("Returns the memory address pointing to the element at the specified Index. Index is always 0-based regardless of the BaseIndex value.") ] + Function AddressOf(Index As Long) As LongPtr +End Interface diff --git a/ArrayListLib/Sources/ListRange.twin b/ArrayListLib/Sources/ListRange.twin index 2442114..61c23e0 100644 --- a/ArrayListLib/Sources/ListRange.twin +++ b/ArrayListLib/Sources/ListRange.twin @@ -1,383 +1,393 @@ - -[ ClassId ("0A102E9C-9E68-411A-A4B8-E6128FC07721") ] -[ COMCreatable (False) ] -Public Class ListRange - Implements IArrayList - Implements ICloneable - Implements ArrayList - - Private pList As IArrayList - Private pIndex As Long - Private pListIndex As Long - Private pVersion As Long - Private pItems() As Variant - Private pBaseIndex As Long - - Private Sub New(Optional ByVal Capacity As Long = 2, Optional ByVal BaseIndex As Long = 0) Implements ArrayList.New - End Sub - - [ Hidden ] - Public Function Bind(TargetList As IArrayList, Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) As ListRange - Static sa As SAFEARRAY_1D - Set pList = TargetList - pBaseIndex = pList.BaseIndex - If IsMissing(Index) Then Index = pBaseIndex - pListIndex = Index - Index -= pBaseIndex - If IsMissing(GetCount) Then GetCount = TargetList.Count - Index - pIndex = GetCount - pVersion = pList.Version - With sa - .cDims = 1 - .cbElements = VARIANT_SIZE - .fFeatures = FADF_VARIANT Or FADF_EMBEDDED - .cLocks = 10 - .pvData = pList.GetAddressOfItemAt(CLng(Index)) - .rgsabound0.cElements = GetCount - End With - PutMemPtr VarPtrArr(pItems), VarPtr(sa) - Return Me - End Function - - Public Property Get BaseIndex() As Long Implements ArrayList.BaseIndex, IArrayList.BaseIndex: Return pBaseIndex: End Property - - Public Property Let BaseIndex(Value As Long) Implements ArrayList.BaseIndex, IArrayList.BaseIndex - pBaseIndex = Value - End Property - - [ Hidden ] - Public Property Get Version() As Long Implements ArrayList.Version, IArrayList.Version - Return pVersion - End Property - - Public Function Add(Value As Variant) As Long Implements ArrayList.Add, IArrayList.Add - Add = pIndex + pBaseIndex - Insert pIndex + pBaseIndex, Value - End Function - - Public Sub AddRange(Target As Variant) Implements ArrayList.AddRange, IArrayList.AddRange - InsertRange pIndex + pBaseIndex, Target - End Sub - - Public Function BinarySearch(ByVal Index As Long, ByVal GetCount As Long, Value As Variant, Optional ByRef Comparer As IComparer = Nothing) As Long Implements ArrayList.BinarySearch, IArrayList.BinarySearch - InternalUpdateRange - Index -= pBaseIndex - If Index < 0 Or GetCount < 0 Or pIndex - Index < GetCount Then Err.Raise 9 - Dim i As Long = pList.BinarySearch(pListIndex + Index, GetCount, Value, Comparer) - Return If(i >= 0, pBaseIndex + i - pListIndex, i + pListIndex - pBaseIndex) - End Function - - Public Property Get Capacity() As Long Implements ArrayList.Capacity, IArrayList.Capacity: Return pList.Capacity: End Property - - Public Property Let Capacity(Value As Long) Implements ArrayList.Capacity, IArrayList.Capacity: End Property - - Public Sub Clear() Implements ArrayList.Clear, IArrayList.Clear - InternalUpdateRange - If pIndex > 0 Then - pList.RemoveRange pListIndex, pIndex - pVersion += 1 - Count = 0 - End If - End Sub - - Public Function Clone() As Variant Implements ArrayList.Clone, ICloneable.Clone - Dim Target As ArrayList - Set Target = New ArrayList(BaseIndex:=pBaseIndex) - C2IArrayList(Target).CloneTo Target, C2IArrayList(Me), 0, pIndex - Return Target - End Function - - Public Function Contains(Value As Variant) As Boolean Implements ArrayList.Contains, IArrayList.Contains - InternalUpdateRange - Dim i As Long, vt As VbVarType = VarType(Value) - Select Case vt - Case vbNull - For i = 0 To pIndex - 1 - If IsNull(pItems(i)) Then Return True - Next i - Case vbObject - For i = 0 To pIndex - 1 - If VarType(pItems(i)) = vt AndAlso ObjPtr(pItems(i)) = ObjPtr(Value) Then Return True - Next i - Case Else - For i = 0 To pIndex - 1 - If VarType(pItems(i)) = vt AndAlso pItems(i) = Value Then Return True - Next i - End Select - End Function - - Public Sub CopyTo(Target As Variant, Index As Long) Implements ArrayList.CopyTo, IArrayList.CopyTo - InternalUpdateRange - Select Case VarType(Target) - Case vbObject - If TypeOf Target Is IListRange Then - C2IListRange(Target).SetRange Index, Me - Else - Err.Raise 13 - End If - Case vbArray + vbVariant - If Index < 0 Or Index > UBound(Target) Then Err.Raise 9 - If UBound(Target) - Index < pIndex Then Err.Raise 6 - VariantArrayClone VarPtr(Target(Index)), VarPtr(pItems(0)), pIndex - Case Else - If Not IsArray(Target) Then Err.Raise 13 - If Index < 0 Or Index > UBound(Target) Then Err.Raise 9 - If UBound(Target) - Index < pIndex Then Err.Raise 6 - Dim i As Long - For i = 0 To pIndex - 1 - Assign Target(Index + i), pItems(i) - Next i - End Select - End Sub - - Public Property Get Count() As Long Implements ArrayList.Count, IArrayList.Count - InternalUpdateRange - Return pIndex - End Property - - Private Property Let Count(ByVal Value As Long) - pIndex = Value - PutMem4 ArrPtr(pItems) + SAFEARRAY_CELEMENTS_OFFSET, Value - End Property - - Private Property Let ArrayList_Count(ByVal Value As Long) Implements ArrayList.Count: Err.Raise 17: End Property - - [ Enumerator ] - [ Description ("When using this enumerator for more advanced usage other than regular For Each usage, Index is always 0-based regardless of the current BaseIndex value in this ArrayList.") ] - Public Function GetEnumerator(Optional ByVal Index As Long = 0, Optional ByVal GetCount As Variant, Optional ByVal GetStep As Long = 1, Optional ByRef ThisEnumerator As IEnumerator) As stdole.IUnknown Implements ArrayList.GetEnumerator, IArrayList.GetEnumerator - Static mEnumerator As Enumerator, mEnumeratorB As Enumerator, mVer As Long, mVerB As Long - If IsMissing(GetCount) Then GetCount = pIndex - Index - If GetCount > 0 Then - If mEnumerator Is Nothing Then - Set mEnumerator = New Enumerator(pItems, Index, GetCount, GetStep, ThisEnumerator) - mVer = pVersion - Else - If pVersion <> mVer Then - mEnumerator.Bind pItems, Index, GetCount, GetStep - mVer = pVersion - Else - If Not mEnumerator.IsAvailable Then - If mEnumeratorB Is Nothing Then - Set mEnumeratorB = New Enumerator(pItems, Index, GetCount, GetStep, ThisEnumerator) - mVerB = pVersion - ElseIf pVersion <> mVerB Then - mEnumeratorB.Bind pItems, Index, GetCount, GetStep - mVerB = pVersion - End If - Set ThisEnumerator = mEnumeratorB - Return mEnumeratorB - End If - End If - End If - Set ThisEnumerator = mEnumerator - Return mEnumerator - End If - End Function - - Public Function GetRange(ByVal Index As Long, ByVal GetCount As Long) As IListRange Implements ArrayList.GetRange, IArrayList.GetRange - InternalUpdateRange - If Index < pBaseIndex Or GetCount < 0 Or pIndex - (Index - pBaseIndex) < GetCount Then Err.Raise 9 - With New ListRange - Return .Bind(Me, Index, GetCount) - End With - End Function - - Public Function IndexOf(Value As Variant, Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) As Long Implements ArrayList.IndexOf, IArrayList.IndexOf - InternalUpdateRange - If IsMissing(Index) Then Index = pBaseIndex - Index -= pBaseIndex - If IsMissing(GetCount) Then GetCount = pIndex - Index - If Index < 0 Or Index > pIndex Or GetCount < 0 Or (Index > pIndex - GetCount) Then Err.Raise 9 - Dim i As Long = pList.IndexOf(Value, pListIndex + Index, GetCount) - Return If(i >= 0, pBaseIndex + i - pListIndex, -1) - End Function - - Public Sub Insert(ByVal Index As Long, Value As Variant) Implements ArrayList.Insert, IArrayList.Insert - InternalUpdateRange - pList.Insert pListIndex + Index - pBaseIndex, Value - Count = pIndex + 1 - pVersion += 1 - End Sub - - Public Sub InsertRange(ByVal Index As Long, Target As Variant) Implements ArrayList.InsertRange, IArrayList.InsertRange - InternalUpdateRange - Dim GetCount As Long = If(IsObject(Target), Target.Count, (UBound(Target) - LBound(Target)) + 1) - pList.InsertRange pListIndex + Index - pBaseIndex, Target - Count = pIndex + GetCount - pVersion += 1 - End Sub - - [ Hidden ] - Public Property Get IsFixedSize() As Boolean Implements ArrayList.IsFixedSize, IArrayList.IsFixedSize: Return False: End Property - [ Hidden ] - Public Property Get IsReadOnly() As Boolean Implements ArrayList.IsReadOnly, IArrayList.IsReadOnly: Return False: End Property - [ Hidden ] - Public Property Get IsSynchronized() As Boolean Implements ArrayList.IsSynchronized, IArrayList.IsSynchronized: Return False: End Property - [ Hidden ] - Public Property Get SyncRoot() As Variant Implements ArrayList.SyncRoot, IArrayList.SyncRoot: Return Nothing: End Property - - [ DefaultMember ] - Public Property Get Item(ByVal Index As Long) As Variant Implements ArrayList.Item, IArrayList.Item - InternalUpdateRange - If Index < pBaseIndex Or Index >= pIndex + pBaseIndex Then Err.Raise 9 - Return pItems(Index - pBaseIndex) - End Property - - Public Property Let Item(ByVal Index As Long, Value As Variant) Implements ArrayList.Item, IArrayList.Item - InternalUpdateRange - If Index < pBaseIndex Or Index >= pIndex + pBaseIndex Then Err.Raise 9 - pItems(Index - pBaseIndex) = Value - pVersion += 1 - End Property - - Public Property Set Item(ByVal Index As Long, Value As Variant) Implements ArrayList.Item, IArrayList.Item - InternalUpdateRange - If Index < pBaseIndex Or Index >= pIndex + pBaseIndex Then Err.Raise 9 - Set pItems(Index - pBaseIndex) = Value - pVersion += 1 - End Property - - [ Hidden ] - [ Description ("CAUTION: Limit usage only in For Each In .Items calls, do NOT assign the return value of .Items to another variable unless you know what you're doing.") ] - Public Function Items() As Variant() Implements ArrayList.Items, IArrayList.Items - /* Returns a 0-based Variant Array pointing to the same memory as the internal array of this list - * without increasing the reference count of byref elements within the list. - * If you assign this array to a variable in your code, you must remove the reference - * before it goes out of scope to prevent double deallocation of byref values. - */ - Static sa As SAFEARRAY_1D - InternalUpdateRange - With sa - .cDims = 1 - .cbElements = VARIANT_SIZE - .fFeatures = FADF_VARIANT Or FADF_AUTO - .cLocks = 10 - .pvData = VarPtr(pItems(0)) - .rgsabound0.cElements = pIndex - End With - VBA.PutMemPtr VarPtrArr(Items), VarPtr(sa) - End Function - - Public Function LastIndexOf(Value As Variant, Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) As Long Implements ArrayList.LastIndexOf, IArrayList.LastIndexOf - InternalUpdateRange - If IsMissing(Index) Then Index = pIndex + pBaseIndex - 1 - Index -= pBaseIndex - If IsMissing(GetCount) Then GetCount = Index + 1 - If Index >= pIndex Or GetCount > Index + 1 Then Err.Raise 9 - If pIndex = 0 Then Return -1 - Dim i As Long = pList.LastIndexOf(Value, pListIndex + Index, GetCount) - Return If(i >= 0, pBaseIndex + i - pListIndex, -1) - End Function - - Public Sub Remove(Value As Variant) Implements ArrayList.Remove, IArrayList.Remove - Dim Index As Long = IndexOf(Value, pBaseIndex) - If Index >= pBaseIndex Then RemoveAt Index - End Sub - - Public Sub RemoveAt(ByVal Index As Long) Implements ArrayList.RemoveAt, IArrayList.RemoveAt - InternalUpdateRange - Index -= pBaseIndex - If Index < 0 Or Index >= pIndex Then Err.Raise 9 - pList.RemoveAt pListIndex + Index - Count = pIndex - 1 - pVersion += 1 - End Sub - - Public Sub RemoveRange(ByVal Index As Long, ByVal GetCount As Long) Implements ArrayList.RemoveRange, IArrayList.RemoveRange - InternalUpdateRange - Index -= pBaseIndex - If Index < 0 Or GetCount < 0 Or (pIndex - Index < GetCount) Then Err.Raise 9 - If GetCount > 0 Then - pList.RemoveRange pListIndex + Index, GetCount - Count = pIndex - GetCount - pVersion += 1 - End If - End Sub - - Public Sub Reverse(Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) Implements ArrayList.Reverse, IArrayList.Reverse - InternalUpdateRange - If IsMissing(Index) Then Index = pBaseIndex - Index -= pBaseIndex - If IsMissing(GetCount) Then GetCount = pIndex - Index - If Index < 0 Or GetCount < 0 Or (pIndex - Index < GetCount) Then Err.Raise 9 - pList.Reverse pListIndex + Index, GetCount - pVersion += 1 - End Sub - - Public Sub SetRange(ByVal Index As Long, Target As Variant) Implements ArrayList.SetRange, IArrayList.SetRange - InternalUpdateRange - Index -= pBaseIndex - If Index < 0 Or Index >= pIndex Then Err.Raise 9 - pList.SetRange pListIndex + Index, Target - pVersion += 1 - End Sub - - Public Sub Sort(Optional ByVal Index As Variant, Optional ByVal GetCount As Variant, Optional Comparer As IComparer = Nothing) Implements ArrayList.Sort, IArrayList.Sort - InternalUpdateRange - If IsMissing(Index) Then Index = pBaseIndex - Index -= pBaseIndex - If IsMissing(GetCount) Then GetCount = pIndex - Index - If Index < 0 Or GetCount < 0 Or (pIndex - Index < GetCount) Then Err.Raise 9 - pList.Sort pListIndex + Index, GetCount, Comparer - pVersion += 1 - End Sub - - Public Function ToArray() As Variant() Implements ArrayList.ToArray, IArrayList.ToArray - InternalUpdateRange - Dim t() As Variant - If pIndex = 0 Then Return Array() - ReDim t(pBaseIndex To pIndex + pBaseIndex - 1) - VariantArrayClone VarPtr(t(pBaseIndex)), VarPtr(pItems(0)), pIndex - ReassignArrayTo ToArray, t - End Function - - Public Function ToString(Optional TextQualifier As String = """", Optional ByVal UseNullAsEmpty As Boolean = True, Optional ByVal UnquotedKeysAllowed As Boolean = False) As String Implements ArrayList.ToString, IArrayList.ToString - Return CommonModule.Stringify(Me, TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) - End Function - - #Region "HIDDEN METHODS IN MSCORLIB" - [ Hidden ] - Public Function IndexOf_2(ByRef Value As Variant, ByVal Index As Long, ByVal GetCount As Long) As Long Implements ArrayList.IndexOf_2: Return IndexOf(Value, Index, GetCount): End Function - [ Hidden ] - Public Function IndexOf_3(ByRef Value As Variant) As Long Implements ArrayList.IndexOf_3: Return IndexOf(Value, pBaseIndex): End Function - [ Hidden ] - Public Sub Sort_2(ByRef Comparer As IComparer) Implements ArrayList.Sort_2: Sort pBaseIndex, , Comparer: End Sub - [ Hidden ] - Public Function BinarySearch_2(ByRef Value As Variant) As Long Implements ArrayList.BinarySearch_2: Return BinarySearch(pBaseIndex, pIndex, Value): End Function - [ Hidden ] - Public Function BinarySearch_3(ByRef Value As Variant, ByRef Comparer As IComparer) As Long Implements ArrayList.BinarySearch_3: Return BinarySearch(pBaseIndex, pIndex, Value, Comparer): End Function - [ Hidden ] - Public Function LastIndexOf_2(ByRef Value As Variant, ByVal Index As Long) As Long Implements ArrayList.LastIndexOf_2: Return LastIndexOf(Value, Index, Index + 1): End Function - [ Hidden ] - Public Function LastIndexOf_3(ByRef Value As Variant, ByVal Index As Long, ByVal GetCount As Long) As Long Implements ArrayList.LastIndexOf_3: Return LastIndexOf(Value, Index, GetCount): End Function - #End Region - - Private Sub Class_Terminate() - On Error Resume Next - PutMemPtr VarPtrArr(pItems), vbNullPtr - Set pList = Nothing - On Error GoTo 0 - End Sub - - Private Function GetAddressOfItemAt(Index As Long) As LongPtr Implements ArrayList.GetAddressOfItemAt, IArrayList.GetAddressOfItemAt - Return VarPtr(pItems(Index)) - End Function - - Private Sub InternalUpdateRange() - If pVersion <> pList.Version Then Err.Raise vbObjectError + 988425, , "This ArrayList range is no longer valid." - End Sub - - Private Sub CloneTo(ByVal Target As IArrayList, Source As IArrayList, ByVal Index As Long, ByVal GetCount As Long) Implements ArrayList.CloneTo, IArrayList.CloneTo: End Sub - - /* [ CompilerOptions ("+llvm,+optimize") ] */ - [ ArrayBoundsChecks (False) ] - [ IntegerOverflowChecks (False) ] - Private Sub Assign(ByRef Target As Variant, ByRef Value As Variant) - If IsObject(Value) Then Set Target = Value Else Target = Value - End Sub - - Private Function C2IArrayList(Value As Variant) As IArrayList: Return Value: End Function - - Private Function C2IListRange(Value As Variant) As IListRange: Return Value: End Function - -End Class + +[ ClassId ("0A102E9C-9E68-411A-A4B8-E6128FC07721") ] +[ COMCreatable (False) ] +Public Class ListRange + Implements IArrayList + Implements ICloneable + Implements IArray + Implements ArrayList + + Private pList As IArrayList + Private pIndex As Long + Private pListIndex As Long + Private pVersion As Long + Private pItems() As Variant + Private pBaseIndex As Long + + Private Sub New(Optional ByVal Capacity As Long = 2, Optional ByVal BaseIndex As Long = 0) Implements ArrayList.New + End Sub + + [ Hidden ] + Public Function Bind(TargetList As IArrayList, Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) As ListRange + Static sa As SAFEARRAY_1D + Set pList = TargetList + pBaseIndex = pList.BaseIndex + If IsMissing(Index) Then Index = pBaseIndex + pListIndex = Index + Index -= pBaseIndex + If IsMissing(GetCount) Then GetCount = TargetList.Count - Index + pIndex = GetCount + pVersion = pList.Version + With sa + .cDims = 1 + .cbElements = VARIANT_SIZE + .fFeatures = FADF_VARIANT Or FADF_EMBEDDED + .cLocks = 10 + .pvData = pList.GetAddressOfItemAt(CLng(Index)) + .rgsabound0.cElements = GetCount + End With + PutMemPtr VarPtrArr(pItems), VarPtr(sa) + Return Me + End Function + + Public Property Get BaseIndex() As Long Implements ArrayList.BaseIndex, IArrayList.BaseIndex, IArray.BaseIndex: Return pBaseIndex: End Property + + Public Property Let BaseIndex(Value As Long) Implements ArrayList.BaseIndex, IArrayList.BaseIndex + pBaseIndex = Value + End Property + + [ Hidden ] + Public Property Get Version() As Long Implements ArrayList.Version, IArrayList.Version + Return pVersion + End Property + + Public Function Add(Value As Variant) As Long Implements ArrayList.Add, IArrayList.Add + Add = pIndex + pBaseIndex + Insert pIndex + pBaseIndex, Value + End Function + + Public Sub AddRange(Target As Variant) Implements ArrayList.AddRange, IArrayList.AddRange + InsertRange pIndex + pBaseIndex, Target + End Sub + + Public Function BinarySearch(ByVal Index As Long, ByVal GetCount As Long, Value As Variant, Optional ByRef Comparer As IComparer = Nothing) As Long Implements ArrayList.BinarySearch, IArrayList.BinarySearch + InternalUpdateRange + Index -= pBaseIndex + If Index < 0 Or GetCount < 0 Or pIndex - Index < GetCount Then Err.Raise 9 + Dim i As Long = pList.BinarySearch(pListIndex + Index, GetCount, Value, Comparer) + Return If(i >= 0, pBaseIndex + i - pListIndex, i + pListIndex - pBaseIndex) + End Function + + Public Property Get Capacity() As Long Implements ArrayList.Capacity, IArrayList.Capacity: Return pList.Capacity: End Property + + Public Property Let Capacity(Value As Long) Implements ArrayList.Capacity, IArrayList.Capacity: End Property + + Public Sub Clear() Implements ArrayList.Clear, IArrayList.Clear + InternalUpdateRange + If pIndex > 0 Then + pList.RemoveRange pListIndex, pIndex + pVersion += 1 + Count = 0 + End If + End Sub + + Public Function Clone() As Variant Implements ArrayList.Clone, ICloneable.Clone + Dim Target As ArrayList + Set Target = New ArrayList(BaseIndex:=pBaseIndex) + C2IArrayList(Target).CloneTo Target, C2IArrayList(Me), 0, pIndex + Return Target + End Function + + Public Function Contains(Value As Variant) As Boolean Implements ArrayList.Contains, IArrayList.Contains + InternalUpdateRange + Dim i As Long, vt As VbVarType = VarType(Value) + Select Case vt + Case vbNull + For i = 0 To pIndex - 1 + If IsNull(pItems(i)) Then Return True + Next i + Case vbObject + For i = 0 To pIndex - 1 + If VarType(pItems(i)) = vt AndAlso ObjPtr(pItems(i)) = ObjPtr(Value) Then Return True + Next i + Case Else + For i = 0 To pIndex - 1 + If VarType(pItems(i)) = vt AndAlso pItems(i) = Value Then Return True + Next i + End Select + End Function + + Public Sub CopyTo(Target As Variant, Index As Long) Implements ArrayList.CopyTo, IArrayList.CopyTo + InternalUpdateRange + Select Case VarType(Target) + Case vbObject + If TypeOf Target Is IListRange Then + C2IListRange(Target).SetRange Index, Me + Else + Err.Raise 13 + End If + Case vbArray + vbVariant + If Index < 0 Or Index > UBound(Target) Then Err.Raise 9 + If UBound(Target) - Index < pIndex Then Err.Raise 6 + VariantArrayClone VarPtr(Target(Index)), VarPtr(pItems(0)), pIndex + Case Else + If Not IsArray(Target) Then Err.Raise 13 + If Index < 0 Or Index > UBound(Target) Then Err.Raise 9 + If UBound(Target) - Index < pIndex Then Err.Raise 6 + Dim i As Long + For i = 0 To pIndex - 1 + Assign Target(Index + i), pItems(i) + Next i + End Select + End Sub + + Public Property Get Count() As Long Implements ArrayList.Count, IArrayList.Count, IArray.Count + InternalUpdateRange + Return pIndex + End Property + + Private Property Let Count(ByVal Value As Long) + pIndex = Value + PutMem4 (Not Not pItems) + SAFEARRAY_OFFSETS.rgsaboundOffset, Value + End Property + + Private Property Let ArrayList_Count(ByVal Value As Long) Implements ArrayList.Count: Err.Raise 17: End Property + + [ Enumerator ] + [ Description ("When using this enumerator for more advanced usage other than regular For Each usage, Index is always 0-based regardless of the current BaseIndex value in this ArrayList.") ] + Public Function GetEnumerator(Optional ByVal Index As Long = 0, Optional ByVal GetCount As Variant, Optional ByVal GetStep As Long = 1, Optional ByRef ThisEnumerator As IEnumerator) As stdole.IUnknown Implements ArrayList.GetEnumerator, IArrayList.GetEnumerator + Static mEnumerator As Enumerator, mEnumeratorB As Enumerator, mVer As Long, mVerB As Long + If IsMissing(GetCount) Then GetCount = pIndex - Index + If GetCount > 0 Then + If mEnumerator Is Nothing Then + Set mEnumerator = New Enumerator(pItems, Index, GetCount, GetStep, ThisEnumerator) + mVer = pVersion + Else + If pVersion <> mVer Then + mEnumerator.Bind pItems, Index, GetCount, GetStep + mVer = pVersion + Else + If Not mEnumerator.IsAvailable Then + If mEnumeratorB Is Nothing Then + Set mEnumeratorB = New Enumerator(pItems, Index, GetCount, GetStep, ThisEnumerator) + mVerB = pVersion + ElseIf pVersion <> mVerB Then + mEnumeratorB.Bind pItems, Index, GetCount, GetStep + mVerB = pVersion + Else + ResetEnumerator(mEnumeratorB) + End If + Set ThisEnumerator = mEnumeratorB + Return mEnumeratorB + Else + ResetEnumerator(mEnumerator) + End If + End If + End If + Set ThisEnumerator = mEnumerator + Return mEnumerator + End If + End Function + + Public Function GetRange(ByVal Index As Long, ByVal GetCount As Long) As IListRange Implements ArrayList.GetRange, IArrayList.GetRange + InternalUpdateRange + If Index < pBaseIndex Or GetCount < 0 Or pIndex - (Index - pBaseIndex) < GetCount Then Err.Raise 9 + With New ListRange + Return .Bind(Me, Index, GetCount) + End With + End Function + + Public Function IndexOf(Value As Variant, Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) As Long Implements ArrayList.IndexOf, IArrayList.IndexOf + InternalUpdateRange + If IsMissing(Index) Then Index = pBaseIndex + Index -= pBaseIndex + If IsMissing(GetCount) Then GetCount = pIndex - Index + If Index < 0 Or Index > pIndex Or GetCount < 0 Or (Index > pIndex - GetCount) Then Err.Raise 9 + Dim i As Long = pList.IndexOf(Value, pListIndex + Index, GetCount) + Return If(i >= 0, pBaseIndex + i - pListIndex, -1) + End Function + + Public Sub Insert(ByVal Index As Long, Value As Variant) Implements ArrayList.Insert, IArrayList.Insert + InternalUpdateRange + pList.Insert pListIndex + Index - pBaseIndex, Value + Count = pIndex + 1 + pVersion += 1 + End Sub + + Public Sub InsertRange(ByVal Index As Long, Target As Variant) Implements ArrayList.InsertRange, IArrayList.InsertRange + InternalUpdateRange + Dim GetCount As Long = If(IsObject(Target), Target.Count, (UBound(Target) - LBound(Target)) + 1) + pList.InsertRange pListIndex + Index - pBaseIndex, Target + Count = pIndex + GetCount + pVersion += 1 + End Sub + + [ Hidden ] + Public Property Get IsFixedSize() As Boolean Implements ArrayList.IsFixedSize, IArrayList.IsFixedSize: Return False: End Property + [ Hidden ] + Public Property Get IsReadOnly() As Boolean Implements ArrayList.IsReadOnly, IArrayList.IsReadOnly: Return False: End Property + [ Hidden ] + Public Property Get IsSynchronized() As Boolean Implements ArrayList.IsSynchronized, IArrayList.IsSynchronized: Return False: End Property + [ Hidden ] + Public Property Get SyncRoot() As Variant Implements ArrayList.SyncRoot, IArrayList.SyncRoot: Return Nothing: End Property + + [ DefaultMember ] + Public Property Get Item(ByVal Index As Long) As Variant Implements ArrayList.Item, IArrayList.Item + InternalUpdateRange + If Index < pBaseIndex Or Index >= pIndex + pBaseIndex Then Err.Raise 9 + Return pItems(Index - pBaseIndex) + End Property + + Public Property Let Item(ByVal Index As Long, Value As Variant) Implements ArrayList.Item, IArrayList.Item + InternalUpdateRange + If Index < pBaseIndex Or Index >= pIndex + pBaseIndex Then Err.Raise 9 + pItems(Index - pBaseIndex) = Value + pVersion += 1 + End Property + + Public Property Set Item(ByVal Index As Long, Value As Variant) Implements ArrayList.Item, IArrayList.Item + InternalUpdateRange + If Index < pBaseIndex Or Index >= pIndex + pBaseIndex Then Err.Raise 9 + Set pItems(Index - pBaseIndex) = Value + pVersion += 1 + End Property + + [ Hidden ] + [ Description ("CAUTION: Limit usage only in For Each In .Items calls, do NOT assign the return value of .Items to another variable unless you know what you're doing.") ] + Public Function Items() As Variant() Implements ArrayList.Items, IArrayList.Items + /* Returns a 0-based Variant Array pointing to the same memory as the internal array of this list + * without increasing the reference count of byref elements within the list. + * If you assign this array to a variable in your code, you must remove the reference + * before it goes out of scope to prevent double deallocation of byref values. + */ + Static sa As SAFEARRAY_1D + InternalUpdateRange + With sa + .cDims = 1 + .cbElements = VARIANT_SIZE + .fFeatures = FADF_VARIANT Or FADF_AUTO + .cLocks = 10 + .pvData = VarPtr(pItems(0)) + .rgsabound0.cElements = pIndex + End With + VBA.PutMemPtr VarPtrArr(Items), VarPtr(sa) + End Function + + Public Function LastIndexOf(Value As Variant, Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) As Long Implements ArrayList.LastIndexOf, IArrayList.LastIndexOf + InternalUpdateRange + If IsMissing(Index) Then Index = pIndex + pBaseIndex - 1 + Index -= pBaseIndex + If IsMissing(GetCount) Then GetCount = Index + 1 + If Index >= pIndex Or GetCount > Index + 1 Then Err.Raise 9 + If pIndex = 0 Then Return -1 + Dim i As Long = pList.LastIndexOf(Value, pListIndex + Index, GetCount) + Return If(i >= 0, pBaseIndex + i - pListIndex, -1) + End Function + + Public Sub Remove(Value As Variant) Implements ArrayList.Remove, IArrayList.Remove + Dim Index As Long = IndexOf(Value, pBaseIndex) + If Index >= pBaseIndex Then RemoveAt Index + End Sub + + Public Sub RemoveAt(ByVal Index As Long) Implements ArrayList.RemoveAt, IArrayList.RemoveAt + InternalUpdateRange + Index -= pBaseIndex + If Index < 0 Or Index >= pIndex Then Err.Raise 9 + pList.RemoveAt pListIndex + Index + Count = pIndex - 1 + pVersion += 1 + End Sub + + Public Sub RemoveRange(ByVal Index As Long, ByVal GetCount As Long) Implements ArrayList.RemoveRange, IArrayList.RemoveRange + InternalUpdateRange + Index -= pBaseIndex + If Index < 0 Or GetCount < 0 Or (pIndex - Index < GetCount) Then Err.Raise 9 + If GetCount > 0 Then + pList.RemoveRange pListIndex + Index, GetCount + Count = pIndex - GetCount + pVersion += 1 + End If + End Sub + + Public Sub Reverse(Optional ByVal Index As Variant, Optional ByVal GetCount As Variant) Implements ArrayList.Reverse, IArrayList.Reverse + InternalUpdateRange + If IsMissing(Index) Then Index = pBaseIndex + Index -= pBaseIndex + If IsMissing(GetCount) Then GetCount = pIndex - Index + If Index < 0 Or GetCount < 0 Or (pIndex - Index < GetCount) Then Err.Raise 9 + pList.Reverse pListIndex + Index, GetCount + pVersion += 1 + End Sub + + Public Sub SetRange(ByVal Index As Long, Target As Variant) Implements ArrayList.SetRange, IArrayList.SetRange + InternalUpdateRange + Index -= pBaseIndex + If Index < 0 Or Index >= pIndex Then Err.Raise 9 + pList.SetRange pListIndex + Index, Target + pVersion += 1 + End Sub + + Public Sub Sort(Optional ByVal Index As Variant, Optional ByVal GetCount As Variant, Optional Comparer As IComparer = Nothing) Implements ArrayList.Sort, IArrayList.Sort + InternalUpdateRange + If IsMissing(Index) Then Index = pBaseIndex + Index -= pBaseIndex + If IsMissing(GetCount) Then GetCount = pIndex - Index + If Index < 0 Or GetCount < 0 Or (pIndex - Index < GetCount) Then Err.Raise 9 + pList.Sort pListIndex + Index, GetCount, Comparer + pVersion += 1 + End Sub + + Public Function ToArray() As Variant() Implements ArrayList.ToArray, IArrayList.ToArray + InternalUpdateRange + Dim t() As Variant + If pIndex = 0 Then Return Array() + ReDim t(pBaseIndex To pIndex + pBaseIndex - 1) + VariantArrayClone VarPtr(t(pBaseIndex)), VarPtr(pItems(0)), pIndex + ReassignArrayTo ToArray, t + End Function + + Private Function IArray_ToArray() As Variant Implements IArray.ToArray + InternalUpdateRange + Dim t() As Variant + If pIndex = 0 Then Return Array() + ReDim t(pBaseIndex To pIndex + pBaseIndex - 1) + VariantArrayClone VarPtr(t(pBaseIndex)), VarPtr(pItems(0)), pIndex + ReassignArrayToVariant IArray_ToArray, t + End Function + + Public Function ToString(Optional TextQualifier As String = """", Optional ByVal UseNullAsEmpty As Boolean = True, Optional ByVal UnquotedKeysAllowed As Boolean = False) As String Implements ArrayList.ToString, IArrayList.ToString + Return CommonModule.Stringify(Me, TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) + End Function + + #Region "HIDDEN METHODS IN MSCORLIB" + [ Hidden ] + Public Function IndexOf_2(ByRef Value As Variant, ByVal Index As Long, ByVal GetCount As Long) As Long Implements ArrayList.IndexOf_2: Return IndexOf(Value, Index, GetCount): End Function + [ Hidden ] + Public Function IndexOf_3(ByRef Value As Variant) As Long Implements ArrayList.IndexOf_3: Return IndexOf(Value, pBaseIndex): End Function + [ Hidden ] + Public Sub Sort_2(ByRef Comparer As IComparer) Implements ArrayList.Sort_2: Sort pBaseIndex, , Comparer: End Sub + [ Hidden ] + Public Function BinarySearch_2(ByRef Value As Variant) As Long Implements ArrayList.BinarySearch_2: Return BinarySearch(pBaseIndex, pIndex, Value): End Function + [ Hidden ] + Public Function BinarySearch_3(ByRef Value As Variant, ByRef Comparer As IComparer) As Long Implements ArrayList.BinarySearch_3: Return BinarySearch(pBaseIndex, pIndex, Value, Comparer): End Function + [ Hidden ] + Public Function LastIndexOf_2(ByRef Value As Variant, ByVal Index As Long) As Long Implements ArrayList.LastIndexOf_2: Return LastIndexOf(Value, Index, Index + 1): End Function + [ Hidden ] + Public Function LastIndexOf_3(ByRef Value As Variant, ByVal Index As Long, ByVal GetCount As Long) As Long Implements ArrayList.LastIndexOf_3: Return LastIndexOf(Value, Index, GetCount): End Function + #End Region + + Private Sub Class_Terminate() + On Error Resume Next + PutMemPtr VarPtrArr(pItems), vbNullPtr + Set pList = Nothing + On Error GoTo 0 + End Sub + + Private Function GetAddressOfItemAt(Index As Long) As LongPtr Implements ArrayList.GetAddressOfItemAt, IArrayList.GetAddressOfItemAt, IArray.AddressOf + Return VarPtr(pItems(Index)) + End Function + + Private Sub InternalUpdateRange() + If pVersion <> pList.Version Then Err.Raise vbObjectError + 988425, , "This ArrayList range is no longer valid." + End Sub + + Private Sub CloneTo(ByVal Target As IArrayList, Source As IArrayList, ByVal Index As Long, ByVal GetCount As Long) Implements ArrayList.CloneTo, IArrayList.CloneTo: End Sub + + /* [ CompilerOptions ("+llvm,+optimize") ] */ + [ ArrayBoundsChecks (False) ] + [ IntegerOverflowChecks (False) ] + Private Sub Assign(ByRef Target As Variant, ByRef Value As Variant) + If IsObject(Value) Then Set Target = Value Else Target = Value + End Sub + +End Class diff --git a/ArrayListLib/Sources/Modules/CommonModule.twin b/ArrayListLib/Sources/Modules/CommonModule.twin index 38e8379..a9b7685 100644 --- a/ArrayListLib/Sources/Modules/CommonModule.twin +++ b/ArrayListLib/Sources/Modules/CommonModule.twin @@ -1,48 +1,104 @@ -Module CommonModule - - [ Hidden ] - Public Function Stringify(Value As Variant, TextQualifier As String, ByVal UseNullAsEmpty As Boolean, ByVal UnquotedKeysAllowed As Boolean) As String - Select Case VarType(Value) - Case vbString: Return TextQualifier & Replace(Value, TextQualifier, TextQualifier & TextQualifier) & TextQualifier - Case vbNull: Return "null" - Case vbEmpty, vbError: Return IIf(UseNullAsEmpty, "null", vbNullString) - Case vbDate: Return TextQualifier & VBA.Format$(ToUTC(CDate(Value)), "yyyy-mm-ddTHH:mm:ss.000Z") & TextQualifier - Case Is >= vbArray, vbObject - Dim v As Variant, s As String - On Error Resume Next - If IsObject(Value) AndAlso TypeOf Value Is ListRange Then - For Each v In CListRange(Value) - s = s & ", " & Stringify(v, TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) - Next v - ElseIf IsObject(Value) AndAlso InStr(TypeName(Value), "Dictionary", Compare:=VbCompareMethod.vbBinaryCompare) >= 0 Then - For Each v In Value.Keys - s = s & ", " & Stringify(If(UnquotedKeysAllowed, v, LTrim(Str(v))), TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) & ": " & Stringify(Value(v), TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) - Next v - On Error GoTo 0 - Return "{" & VBA.Mid$(s, 3) & "}" - Else - For Each v In Value - s = s & ", " & Stringify(v, TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) - Next v - End If - On Error GoTo 0 - Return "[" & VBA.Mid$(s, 3) & "]" - Case Else: Return LTrim(Str(Value)) - End Select - End Function - - Private Function ToUTC(Value As Date) As Date - Static tzOffset As Long = -1 - If tzOffset = -1 Then - With CreateObject("htmlfile") - .write "" - .Close - tzOffset = CLng(Val(.parentWindow.tzo)) - End With - End If - Return DateAdd("n", tzOffset, Value) - End Function - - Private Function CListRange(Value As Variant) As ListRange: Set CListRange = Value: End Function - -End Module +Module CommonModule + + [ Hidden ] + Public Function Stringify(Value As Variant, TextQualifier As String, ByVal UseNullAsEmpty As Boolean, ByVal UnquotedKeysAllowed As Boolean) As String + Select Case VarType(Value) + Case vbString: Return TextQualifier & Replace(Value, TextQualifier, TextQualifier & TextQualifier) & TextQualifier + Case vbNull: Return "null" + Case vbEmpty, vbError: Return IIf(UseNullAsEmpty, "null", vbNullString) + Case vbDate: Return TextQualifier & VBA.Format$(ToUTC(CDate(Value)), "yyyy-mm-ddTHH:mm:ss.000Z") & TextQualifier + Case Is >= vbArray, vbObject + Dim v As Variant, s As String + On Error Resume Next + If IsObject(Value) AndAlso TypeOf Value Is ListRange Then + For Each v In CListRange(Value) + s = s & ", " & Stringify(v, TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) + Next v + ElseIf IsObject(Value) AndAlso InStr(TypeName(Value), "Dictionary", Compare:=VbCompareMethod.vbBinaryCompare) > 0 Then + For Each v In Value.Keys + s = s & ", " & Stringify(If(UnquotedKeysAllowed, v, LTrim(Str(v))), TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) & ": " & Stringify(Value(v), TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) + Next v + On Error GoTo 0 + Return "{" & VBA.Mid$(s, 3) & "}" + Else + For Each v In Value + s = s & ", " & Stringify(v, TextQualifier, UseNullAsEmpty, UnquotedKeysAllowed) + Next v + End If + On Error GoTo 0 + Return "[" & VBA.Mid$(s, 3) & "]" + Case Else: Return LTrim(Str(Value)) + End Select + End Function + + Private Function ToUTC(Value As Date) As Date + Static tzOffset As Long = -1 + If tzOffset = -1 Then + With CreateObject("htmlfile") + .write "" + .Close + tzOffset = CLng(Val(.parentWindow.tzo)) + End With + End If + Return DateAdd("n", tzOffset, Value) + End Function + + Private Function CListRange(Value As Variant) As ListRange: Return Value: End Function + + Public Function C2IArrayList(Value As Variant) As IArrayList: Return Value: End Function + + Public Function C2IListRange(Value As Variant) As IListRange: Return Value: End Function + + Public Function C2IArray(Value As Variant) As IArray: Return Value: End Function + + Public Sub ResetEnumerator(Target As IEnumerator): Target.Reset: End Sub + + #If Win64 Then + Const VARIANT_VT_ZERO_MASK As LongPtr = &HFFFFFFFFFFFF0000^ + #Else + Const VARIANT_VT_ZERO_MASK As LongPtr = &HFFFF0000& + #End If + + Public Sub SafeArrayDescriptorAndVT(TargetArray As LongPtr, ByRef PTR As LongPtr, ByRef VT As Integer) + GetMemPtr TargetArray, PTR + If ((PTR And VARIANT_VT_ZERO_MASK) = 0) Then + VT = CInt(PTR And &HFF&) + Select Case (PTR And &HFF00&) + Case vbArray + GetMemPtr TargetArray + 8, PTR + Case vbArray + VT_BYREF + GetMemPtr TargetArray + 8, PTR + GetMemPtr PTR, PTR + Case Else + PTR = vbNullPtr + Exit Sub + End Select + Else + GetMem2 PTR - 4, VT + End If + Select Case VT + Case 2 To 14, 17, 20, 36: Exit Sub + End Select + PTR = vbNullPtr + End Sub + + Public Sub SizeOfVT(VT As Integer, ByRef ByteCount As Long) + Select Case VT + Case vbInteger: ByteCount = LenB(Of Integer) + Case vbLong: ByteCount = LenB(Of Long) + Case vbSingle: ByteCount = LenB(Of Single) + Case vbDouble: ByteCount = LenB(Of Double) + Case vbCurrency: ByteCount = LenB(Of Currency) + Case vbDate: ByteCount = LenB(Of Date) + Case vbString: ByteCount = LenB(Of String) + Case vbObject: ByteCount = LenB(Of Object) + Case vbBoolean: ByteCount = LenB(Of Boolean) + Case vbVariant: ByteCount = LenB(Of Variant) + Case vbDecimal: ByteCount = LenB(Of Decimal) + Case vbByte: ByteCount = LenB(Of Byte) + Case vbLongLong: ByteCount = LenB(Of LongLong) + Case vbLongLong: ByteCount = LenB(Of LongPtr) + End Select + End Sub + +End Module diff --git a/ArrayListLib/Sources/Modules/LibMemory.twin b/ArrayListLib/Sources/Modules/LibMemory.twin index 241e850..b5af516 100644 --- a/ArrayListLib/Sources/Modules/LibMemory.twin +++ b/ArrayListLib/Sources/Modules/LibMemory.twin @@ -1,91 +1,120 @@ -Module LibMemory - '''============================================================================= - ''' VBA MemoryTools - ''' ----------------------------------------------- - ''' https://github.com/cristianbuse/VBA-MemoryTools - ''' ----------------------------------------------- - ''' MIT License - ''' - ''' Copyright (c) 2020 Ion Cristian Buse - ''' - ''' Permission is hereby granted, free of charge, to any person obtaining a copy - ''' of this software and associated documentation files (the "Software"), to - ''' deal in the Software without restriction, including without limitation the - ''' rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - ''' sell copies of the Software, and to permit persons to whom the Software is - ''' furnished to do so, subject to the following conditions: - ''' - ''' The above copyright notice and this permission notice shall be included in - ''' all copies or substantial portions of the Software. - ''' - ''' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - ''' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - ''' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE - ''' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - ''' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING - ''' FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS - ''' IN THE SOFTWARE. - '''============================================================================= - - #If Win64 Then - Public Const PTR_SIZE As Long = 8 - Public Const VARIANT_SIZE As Long = 24 - #Else - Public Const PTR_SIZE As Long = 4 - Public Const VARIANT_SIZE As Long = 16 - #End If - Public Const INT_SIZE As Long = 2 - Public Const VT_BYREF As Long = &H4000 - - Public Type SAFEARRAYBOUND - cElements As Long - lLbound As Long - End Type - - Public Type SAFEARRAY_1D - cDims As Integer - fFeatures As Integer - cbElements As Long - cLocks As Long - #If Win64 Then - dummyPadding As Long - pvData As LongLong - #Else - pvData As Long - #End If - rgsabound0 As SAFEARRAYBOUND - End Type - - '******************************************************************************* - 'Returns the memory address of a variable of array type - 'Returns error 5 for a non-array or an array wrapped in a Variant - '******************************************************************************* - Public Function VarPtrArr(ByRef arr As Variant) As LongPtr - Const vtArrByRef As Long = vbArray + VT_BYREF - Dim vt As Integer - VBA.GetMem2 VarPtr(arr), vt - If (vt And vtArrByRef) = vtArrByRef Then - Const pArrayOffset As Long = 8 - VBA.GetMemPtr VarPtr(arr) + pArrayOffset, VarPtrArr - Else - Err.Raise 5, "VarPtrArr", "Array required" - End If - End Function - - '******************************************************************************* - 'Returns the pointer to the underlying SAFEARRAY structure of a VB array - 'Returns error 5 for a non-array - '******************************************************************************* - Public Function ArrPtr(ByRef arr As Variant) As LongPtr - Dim vt As Integer - VBA.GetMem2 VarPtr(arr), vt - If vt And vbArray Then - Const pArrayOffset As Long = 8 - VBA.GetMemPtr VarPtr(arr) + pArrayOffset, ArrPtr - If vt And VT_BYREF Then VBA.GetMemPtr ArrPtr, ArrPtr - Else - Err.Raise 5, "ArrPtr", "Array required" - End If - End Function - -End Module +Module LibMemory + '''============================================================================= + ''' VBA MemoryTools + ''' ----------------------------------------------- + ''' https://github.com/cristianbuse/VBA-MemoryTools + ''' ----------------------------------------------- + ''' MIT License + ''' + ''' Copyright (c) 2020 Ion Cristian Buse + ''' + ''' Permission is hereby granted, free of charge, to any person obtaining a copy + ''' of this software and associated documentation files (the "Software"), to + ''' deal in the Software without restriction, including without limitation the + ''' rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + ''' sell copies of the Software, and to permit persons to whom the Software is + ''' furnished to do so, subject to the following conditions: + ''' + ''' The above copyright notice and this permission notice shall be included in + ''' all copies or substantial portions of the Software. + ''' + ''' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + ''' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + ''' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + ''' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + ''' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + ''' FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + ''' IN THE SOFTWARE. + '''============================================================================= + + #If Win64 Then + Public Const PTR_SIZE As Long = 8 + Public Const VARIANT_SIZE As Long = 24 + #Else + Public Const PTR_SIZE As Long = 4 + Public Const VARIANT_SIZE As Long = 16 + #End If + Public Const INT_SIZE As Long = 2 + Public Const VT_BYREF As Long = &H4000 + + Public Type SAFEARRAYBOUND + cElements As Long + lLbound As Long + End Type + + Public Type SAFEARRAY_1D + cDims As Integer + fFeatures As Integer + cbElements As Long + cLocks As Long + #If Win64 Then + dummyPadding As Long + pvData As LongLong + #Else + pvData As Long + #End If + rgsabound0 As SAFEARRAYBOUND + End Type + + Public Enum SAFEARRAY_FEATURES + FADF_AUTO = &H1 + FADF_STATIC = &H2 + FADF_EMBEDDED = &H4 + FADF_FIXEDSIZE = &H10 + FADF_RECORD = &H20 + FADF_HAVEIID = &H40 + FADF_HAVEVARTYPE = &H80 + FADF_BSTR = &H100 + FADF_UNKNOWN = &H200 + FADF_DISPATCH = &H400 + FADF_VARIANT = &H800 + FADF_RESERVED = &HF008& + End Enum + + Public Enum SAFEARRAY_OFFSETS + cDimsOffset = 0 + fFeaturesOffset = 2 + cbElementsOffset = 4 + cLocksOffset = 8 + #If Win64 Then + pvDataOffset = 16 + rgsaboundOffset = 24 + #Else + pvDataOffset = 12 + rgsaboundOffset = 16 + #End If + End Enum + + '******************************************************************************* + 'Returns the memory address of a variable of array type + 'Returns error 5 for a non-array or an array wrapped in a Variant + '******************************************************************************* + Public Function VarPtrArr(ByRef arr As Variant) As LongPtr + Const vtArrByRef As Long = vbArray + VT_BYREF + Dim vt As Integer + VBA.GetMem2 VarPtr(arr), vt + If (vt And vtArrByRef) = vtArrByRef Then + Const pArrayOffset As Long = 8 + VBA.GetMemPtr VarPtr(arr) + pArrayOffset, VarPtrArr + Else + Err.Raise 5, "VarPtrArr", "Array required" + End If + End Function + + '******************************************************************************* + 'Returns the pointer to the underlying SAFEARRAY structure of a VB array + 'Returns error 5 for a non-array + '******************************************************************************* + Public Function ArrPtr(ByRef arr As Variant) As LongPtr + Dim vt As Integer + VBA.GetMem2 VarPtr(arr), vt + If vt And vbArray Then + Const pArrayOffset As Long = 8 + VBA.GetMemPtr VarPtr(arr) + pArrayOffset, ArrPtr + If vt And VT_BYREF Then VBA.GetMemPtr ArrPtr, ArrPtr + Else + Err.Raise 5, "ArrPtr", "Array required" + End If + End Function + +End Module diff --git a/ArrayListLib/Sources/Modules/LibMemoryEx.twin b/ArrayListLib/Sources/Modules/LibMemoryEx.twin index 30d1b4d..84b4dd8 100644 --- a/ArrayListLib/Sources/Modules/LibMemoryEx.twin +++ b/ArrayListLib/Sources/Modules/LibMemoryEx.twin @@ -1,113 +1,113 @@ -Public Module LibMemoryEx - - Public DeclareWide PtrSafe Sub RtlMoveMemory Lib "kernel32" (ByVal lpDest As LongPtr, ByVal lpSource As LongPtr, ByVal Size As LongPtr) - Private Declare PtrSafe Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte) - Private Declare PtrSafe Function SafeArrayCopyData Lib "oleaut32" (ByRef psaSource As Any, ByRef psaTarget As Any) As Long - - Public Const FADF_AUTO As Long = &H1 ' An array that is allocated on the stack. - Public Const FADF_VARIANT As Long = &H800 ' An array of VARIANTs. - Public Const FADF_EMBEDDED As Long = &H4 ' An array that is embedded in a structure. - Public Const FADF_FIXEDSIZE As Long = &H10 ' An array that may not be resized or reallocated. - Public Const FADF_HAVEVARTYPE As Long = &H80 ' An array that has a variant type. The variant type can be retrieved with SafeArrayGetVartype. - - Public Const SAFEARRAY_PVDATA_OFFSET As Long = 8 + PTR_SIZE - Public Const SAFEARRAY_CELEMENTS_OFFSET As Long = VARIANT_SIZE / INT_SIZE + 4 + PTR_SIZE - Public Const SAFEARRAY_LLBOUND_OFFSET As Long = VARIANT_SIZE / INT_SIZE + 8 + PTR_SIZE - - Public Sub ReassignArrayTo(ByRef Destination As Variant, ByRef Source As Variant) - Dim p As LongPtr - VBA.GetMemPtr VarPtrArr(Source), p - VBA.PutMemPtr VarPtrArr(Destination), p - VBA.PutMemPtr VarPtrArr(Source), vbNullPtr - End Sub - - Public Sub ZeroMemory(ByVal TargetAddress As LongPtr, ByVal ByteCount As Long) - FillMemory ByVal TargetAddress, ByteCount, CByte(0) - End Sub - - Public Sub VariantArrayClone(ByVal DestinationAddress As LongPtr, ByVal SourceAddress As LongPtr, ByVal GetCount As Long, Optional ByVal ArrayElementSize As Long = VARIANT_SIZE) - Dim sASrc As SAFEARRAY_1D, sADst As SAFEARRAY_1D - With sASrc - .cDims = 1 - .cbElements = ArrayElementSize - .fFeatures = IIf(ArrayElementSize = VARIANT_SIZE, FADF_VARIANT, 0) - .pvData = SourceAddress - .rgsabound0.cElements = GetCount - End With - With sADst - .cDims = 1 - .cbElements = ArrayElementSize - .fFeatures = IIf(ArrayElementSize = VARIANT_SIZE, FADF_VARIANT Or FADF_EMBEDDED, FADF_EMBEDDED) - .pvData = DestinationAddress - .rgsabound0.cElements = GetCount - End With - SafeArrayCopyData ByVal VarPtr(sASrc), ByVal VarPtr(sADst) - With sASrc - .pvData = vbNullPtr - .rgsabound0.cElements = 0 - End With - With sADst - .cbElements = 2 - .fFeatures = FADF_EMBEDDED - .pvData = vbNullPtr - .rgsabound0.cElements = 0 - End With - End Sub - - Public Sub MemMoveEx(ByVal Target As LongPtr, ByVal Source As LongPtr, ByVal ByteCount As LongPtr) - Const MAX_LONG As Long = &H7FFFFFFF& - If Target > Source Then - If Source + ByteCount > Target Then - ' Move Forward + Overlapping - #If Win64 Then - RtlMoveMemory Target, Source, ByteCount - #Else - Const chunkSize As Long = VARIANT_SIZE * 4000 - Dim c As Long, nChunks As Long = CLng((ByteCount - 1) \ chunkSize) - MemMoveBSTR Target + (nChunks * chunkSize), Source + (nChunks * chunkSize), CLng(ByteCount - nChunks * chunkSize) - For c = nChunks - 1 To 0 Step -1 - MemMoveBSTR Target + (c * chunkSize), Source + (c * chunkSize), chunkSize - Next c - #End If - ElseIf ByteCount < MAX_LONG Then - ' Move Forward + No overlapping - VBA.vbaCopyBytes CLng(ByteCount), Target, Source - Else - ' Move Forward + No overlapping + More than 2GB exceeding Long - RtlMoveMemory Target, Source, ByteCount - End If - ElseIf ByteCount < MAX_LONG Then - ' Move Backwards - VBA.vbaCopyBytes CLng(ByteCount), Target, Source - Else - ' Move Backwards + More than 2GB exceeding Long - RtlMoveMemory Target, Source, ByteCount - End If - End Sub - - Type UDTStringPointer - Value As String - End Type - - Private Sub LSetByVal(ByRef Target As UDTStringPointer, ByVal Value As String) - LSet Target.Value = Value - End Sub - - ' CopyMemory (Win32/Forward-only) using BSTR/LSet - Private Sub MemMoveBSTR(ByRef Target As LongPtr, ByRef Source As LongPtr, ByVal ByteCount As Long) - Dim lbs0 As Long, lbs1 As Long, src As String - VBA.GetMem4 Source, lbs0 - VBA.GetMem4 Target, lbs1 - VBA.PutMem4 Source, ByteCount - 4 - VBA.PutMem4 Target, ByteCount - 4 - VBA.PutMemPtr VarPtr(src), Source + 4 - LSetByVal Target + 4, src - VBA.PutMemPtr VarPtr(src), vbNullPtr - VBA.PutMem4 Target, lbs0 - VBA.PutMem4 Source, lbs0 - If ByteCount > Target - Source Then - VBA.PutMem4 Target + (Target - Source), lbs1 - End If - End Sub - -End Module +Public Module LibMemoryEx + + Public DeclareWide PtrSafe Sub RtlMoveMemory Lib "kernel32" (ByVal lpDest As LongPtr, ByVal lpSource As LongPtr, ByVal Size As LongPtr) + Private Declare PtrSafe Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte) + Private Declare PtrSafe Function SafeArrayCopyData Lib "oleaut32" (ByRef psaSource As Any, ByRef psaTarget As Any) As Long + + [ Description ("Points the Destination array to Source's SafeArray while setting Source to vbNullPtr. Both Destination and Source have to be arrays, not variants.") ] + Public Sub ReassignArrayTo(ByRef Destination As Variant, ByRef Source As Variant) + Dim p As LongPtr + GetMemPtr VarPtrArr(Source), p + PutMemPtr VarPtrArr(Destination), p + PutMemPtr VarPtrArr(Source), vbNullPtr + End Sub + + [ Description ("Does the same as ReassignArrayTo, except that requires a Variant instead of an actual array as Destination.") ] + Public Sub ReassignArrayToVariant(ByRef Destination As Variant, ByRef Source As Variant) + Dim p As LongPtr, vType As Integer + SafeArrayDescriptorAndVT VarPtr(Source), p, vType + PutMem2 VarPtr(Destination), vType + vbArray + PutMemPtr VarPtr(Destination) + 8, p + PutMemPtr VarPtrArr(Source), vbNullPtr + End Sub + + Public Sub ZeroMemory(ByVal TargetAddress As LongPtr, ByVal ByteCount As Long) + FillMemory ByVal TargetAddress, ByteCount, CByte(0) + End Sub + + Public Sub VariantArrayClone(ByVal DestinationAddress As LongPtr, ByVal SourceAddress As LongPtr, ByVal GetCount As Long, Optional ByVal ArrayElementSize As Long = VARIANT_SIZE) + Dim sASrc As SAFEARRAY_1D, sADst As SAFEARRAY_1D + With sASrc + .cDims = 1 + .cbElements = ArrayElementSize + .fFeatures = IIf(ArrayElementSize = VARIANT_SIZE, FADF_VARIANT, 0) + .pvData = SourceAddress + .rgsabound0.cElements = GetCount + End With + With sADst + .cDims = 1 + .cbElements = ArrayElementSize + .fFeatures = IIf(ArrayElementSize = VARIANT_SIZE, FADF_VARIANT Or FADF_EMBEDDED, FADF_EMBEDDED) + .pvData = DestinationAddress + .rgsabound0.cElements = GetCount + End With + SafeArrayCopyData ByVal VarPtr(sASrc), ByVal VarPtr(sADst) + With sASrc + .pvData = vbNullPtr + .rgsabound0.cElements = 0 + End With + With sADst + .cbElements = 2 + .fFeatures = FADF_EMBEDDED + .pvData = vbNullPtr + .rgsabound0.cElements = 0 + End With + End Sub + + Public Sub MemMoveEx(ByVal Target As LongPtr, ByVal Source As LongPtr, ByVal ByteCount As LongPtr) + Const MAX_LONG As Long = &H7FFFFFFF& + If Target > Source Then + If Source + ByteCount > Target Then + ' Move Forward + Overlapping + #If Win64 Then + RtlMoveMemory Target, Source, ByteCount + #Else + Const chunkSize As Long = VARIANT_SIZE * 4000 + Dim c As Long, nChunks As Long = CLng((ByteCount - 1) \ chunkSize) + MemMoveBSTR Target + (nChunks * chunkSize), Source + (nChunks * chunkSize), CLng(ByteCount - nChunks * chunkSize) + For c = nChunks - 1 To 0 Step -1 + MemMoveBSTR Target + (c * chunkSize), Source + (c * chunkSize), chunkSize + Next c + #End If + ElseIf ByteCount < MAX_LONG Then + ' Move Forward + No overlapping + VBA.vbaCopyBytes CLng(ByteCount), Target, Source + Else + ' Move Forward + No overlapping + More than 2GB exceeding Long + RtlMoveMemory Target, Source, ByteCount + End If + ElseIf ByteCount < MAX_LONG Then + ' Move Backwards + VBA.vbaCopyBytes CLng(ByteCount), Target, Source + Else + ' Move Backwards + More than 2GB exceeding Long + RtlMoveMemory Target, Source, ByteCount + End If + End Sub + + Type UDTStringPointer + Value As String + End Type + + Private Sub LSetByVal(ByRef Target As UDTStringPointer, ByVal Value As String) + LSet Target.Value = Value + End Sub + + ' CopyMemory (Win32/Forward-only) using BSTR/LSet + Private Sub MemMoveBSTR(ByRef Target As LongPtr, ByRef Source As LongPtr, ByVal ByteCount As Long) + Dim lbs0 As Long, lbs1 As Long, src As String + VBA.GetMem4 Source, lbs0 + VBA.GetMem4 Target, lbs1 + VBA.PutMem4 Source, ByteCount - 4 + VBA.PutMem4 Target, ByteCount - 4 + VBA.PutMemPtr VarPtr(src), Source + 4 + LSetByVal Target + 4, src + VBA.PutMemPtr VarPtr(src), vbNullPtr + VBA.PutMem4 Target, lbs0 + VBA.PutMem4 Source, lbs0 + If ByteCount > Target - Source Then + VBA.PutMem4 Target + (Target - Source), lbs1 + End If + End Sub + +End Module