What's this?
Some "Heap-Class"
You may declare any variable to be tHeap-Memory. tHeap can store anything.
More sophisticated the Extension tTypedHeap, allows to store a variable-type/udt-information together with the data but also uses just 4 bytes to store a pointer.
Any more information gets stored to the types static members
tTypedHeap is dynamic arrays of any fixed size type as well as dynamic strings, data from heap can be saved & loaded by just one call.
3 Units
(one just to enumerate type-names, required by tHeap-Unit)
' Filename "Type_Enumerate.tBasicU"
' to create a global uniform Type-name-enumeration
' every type gets stored only once
' the "enumerated" number can be used to compare types.
' every "enumerated" number is unique since it's a memory-pointer
' which is valid until the script ends
' all type-names get stored in UCase and can be read out at this
' pointer using Heap_Get()
'---------------------------------------------------------------------------------
Function Type_Enumerate(ByVal sType As String, _
Optional ByVal TestExist As Boolean _
) As DWord
'---------------------------------------------------------------------------------
Static hAllTypes As DWord
' this points a heap with a list of pointers to all enumerated type-names
Local Index As Long ' will hold the index of requested pointer
If Not Type_Exists(sType) Then Return 0 ' if it's not a type then return nothing
sType = Ucase$(sType) ' from here all type-names work in UCASE
If HEAP_Size(hAllTypes) Then ' are there any pointers already?
' place virtual Dword-array upon the pointer-list:
Local vPtr(HEAP_Size(hAllTypes)/4) As DWord At hAllTypes
' and scan if any of the list points the requested type-name
Index = Array Scan vPtr Ptr, = sType
If Index Then
Return vPtr(Index)
EndIf
EndIf
' does not exist yet:
If TestExist Then Return 0
' store sType and append its Pointer to function-static hAllTypes
hAllTypes = HEAP_ReAllocByStr(hAllTypes, HEAP_Get(hAllTypes) & MKDWD$(HEAP_AllocByStr(sType)) )
' return last appended pointer
Function = Peek(DWord, HEAP_End(hAllTypes) - 3 )
' use Heap_Get on the result to read the type-name out
End Function
this the unit that contains all the heap-functions:
#MINVERSION 1.9.15.0
' Filename "tHeap.tBasicU"
#INCLUDE Once "Type_Enumerate.tBasicU"
' #####################################################################
Type tHeap
' #####################################################################
pData As DWord
Static allowZeroAllocation As Boolean ' global setting to all tHeap
Alloc As Function
ReAlloc As Function
AllocByStr As Function
GetSize As Function ' i.e. Size in Bytes
Copy As Function
EndPtr As Function ' position of last Byte = Heap_End()
Free As Function
GetBytes As Function ' replaces Heap_Get, Heap_Left, Heap_Mid, Heap_Right
GetData As Function ' Heap_Get
Load As Function
Save As Function
End Type
' ----------------------------------------------------------------------
Function tHeap.Alloc(ByVal nBytes As Long) As DWord
' ----------------------------------------------------------------------
If nBytes < 1 Then
HEAP_ReAllocByStr(Me.pData, "", Me.allowZeroAllocation)
Else
Me.pData = HEAP_Alloc(nBytes)
EndIf
Function = Me.pData
End Function
' ----------------------------------------------------------------------
Function tHeap.ReAlloc(ByVal nBytes As Long) As DWord
' ----------------------------------------------------------------------
If nBytes < 1 Then
HEAP_ReAllocByStr(Me.pData, "", Me.allowZeroAllocation)
Else
Me.pData = HEAP_Realloc(Me.pData, nBytes)
EndIf
Function = Me.pData
End Function
' ----------------------------------------------------------------------
Function tHeap.AllocByStr(ByVal sData As String) As DWord
' ----------------------------------------------------------------------
' works as re-alloc also
Me.pData = HEAP_ReAllocByStr(Me.pData, sData, Me.allowZeroAllocation)
Function = Me.pData
End Function
' ----------------------------------------------------------------------
Function tHeap.Copy(ByRef Sourceheap As tHeap) As DWord
' ----------------------------------------------------------------------
Me.pData = HEAP_ReAllocByStr(Me.pData, HEAP_Get(Sourceheap.pData), Me.allowZeroAllocation )
Function = Me.pData
End Function
' ----------------------------------------------------------------------
Function tHeap.EndPtr() As DWord
' ----------------------------------------------------------------------
Function = HEAP_End(Me.pData)
End Function
' ----------------------------------------------------------------------
Function tHeap.Free() As DWord
' ----------------------------------------------------------------------
HEAP_Free( Me.pData )
Me.pData = 0
Function = 0
End Function
' ----------------------------------------------------------------------
Function tHeap.GetSize() As Long
' ----------------------------------------------------------------------
Function = HEAP_Size(Me.pData)
End Function
' ----------------------------------------------------------------------
Function tHeap.GetBytes( _
Optional ByVal bFirst As Long, _
ByVal bCount As Long _
) As String
' ----------------------------------------------------------------------
If HEAP_Size(Me.pData) = 0 Then Exit Function
If bCount < 1 Then
If bFirst < 1 Then
' = all bytes by default:
Return HEAP_Get(Me.pData)
EndIf
' use all starting with the first
bCount = HEAP_Size(Me.pData) - bFirst + 1
EndIf
If Between(bFirst, 1, HEAP_Size(Me.pData)) Then
bCount = MinMax(bCount, 1, HEAP_Size(Me.pData) - bFirst + 1)
Return Memory_Get(Me.pData + bFirst - 1, bCount)
Else
' first out of range, so take bCount bytes from the end
bCount = MinMax(bCount, 1, HEAP_Size(Me.pData))
Return Memory_Get(HEAP_End(Me.pData) - bCount + 1, bCount )
EndIf
End Function
' ----------------------------------------------------------------------
Function tHeap.GetData() As String
' ----------------------------------------------------------------------
If HEAP_Size(Me.pData) = 0 Then Exit Function
Function = Memory_Get(Me.pData, HEAP_Size(Me.pData))
End Function
' ----------------------------------------------------------------------
Function tHeap.Load(ByVal sFilename As String) As DWord
' ----------------------------------------------------------------------
Function = Me.AllocByStr(Load_File(sFilename))
End Function
' ----------------------------------------------------------------------
Function tHeap.Save(ByVal sFilename As String) As Boolean
' ----------------------------------------------------------------------
Function = ( Save_File( sFilename, HEAP_Get(Me.pData) ) = 0 )
End Function
' ----------------------------------------------------------------------
' Function tHeap. ()
' ----------------------------------------------------------------------
' End Function
' ######################################################################
Type tTypedHeap Extends tHeap
' ######################################################################
Static pTypes As DWord
Static pVarPtrs As DWord
GetKeyIndex As Function
AllocAs As Function
Free As Function
GetData As Function
GetType As Function
GetUBound As Function
SetData As Function
AddData As Function
Load As Function
Save As Function
End Type
' PRIVATE
'---------------------------------------------------------------------------------
Function tTypedHeap.GetKeyIndex(Optional ByVal testExist As Boolean) As Long
'---------------------------------------------------------------------------------
' returns Index of this if available
' or creates new slot if not testExist
' the local key is the varptr:
Local lKey As DWord = VarPtr(Me)
Local lResult As Long
If HEAP_Size(Me.pVarptrs) >= 4 Then
Local lPtr(HEAP_Size(Me.pVarptrs)/4) As DWord At Me.pVarPtrs
lResult = Array Scan lPtr, = lKey
If lResult Then Return lResult
EndIf
If testExist Then Return 0
' make a new one:
Me.pVarptrs = HEAP_ReAllocByStr(Me.pVarptrs, HEAP_Get(Me.pVarptrs) & MKDWD$(lKey))
Me.pTypes = HEAP_ReAllocByStr(Me.pTypes, HEAP_Get(Me.pTypes) & MKDWD$(0))
Function = HEAP_Size(Me.pVarptrs)/4
End Function
' PUBLIC
'---------------------------------------------------------------------------------
Function tTypedHeap.AllocAs(ByVal sType As String, _
Optional ByVal lUbound As Long = 1, _
ByVal sData As String _
) As String
'---------------------------------------------------------------------------------
' this will allocate desired space and store the types name
Local kI As Long = Me.GetKeyIndex()
Local pType(kI) As DWord At Me.pTypes
If HEAP_Size(Me.pData) Then Me.Free()
pType(kI) = Type_Enumerate(sType)
If Not pType(kI) Then Return "Byte"
lUbound = MinMax(lUbound, 1, &H7FFFFFFF )
If HEAP_Get(pType(kI)) = "STRING" Then
' = dword-array of heap-pointers
Me.pData = HEAP_Alloc(lUbound * 4)
If StrPtrLen(StrPtr(sData)) Then
Poke(DWord, Me.pData, HEAP_AllocByStr(sData))
EndIf
Function = "DWORD"
Else
Local data Like sType At 0
Select Case StrPtrLen(StrPtr(sData))
Case 0
Me.pData = HEAP_Alloc(lUbound * SizeOf(data))
Case >= lUbound * SizeOf(data)
Me.pData = HEAP_AllocByStr(sData)
Case Else
Me.pData = HEAP_Alloc(lUbound * SizeOf(data))
Memory_Set(Me.pData, sData)
End Select
Function = sType
EndIf
End Function
'---------------------------------------------------------------------------------
Function tTypedHeap.Free() As DWord
'---------------------------------------------------------------------------------
' free the data only!
' this won't change/delete the previously assigned type
' type will stay valid until .AllocAs("something else")
If Me.GetType() = "STRING" Then
If HEAP_Size(Me.pData) > 3 Then
Local pData As DWord At Me.pData
Do
HEAP_Free(pData)
SetAt(pData, GetAt(pData)+4)
Loop Until GetAt(pData) > HEAP_End(Me.pData)
EndIf
EndIf
HEAP_Free(Me.pData)
Me.pData = 0
End Function
'---------------------------------------------------------------------------------
Function tTypedHeap.GetType() As String
'---------------------------------------------------------------------------------
' this will return the stored Type-name if one
Local kI As Long = Me.GetKeyIndex(TRUE) ' true means check for existance
If kI = 0 Then Return "byte" ' get out of here
Local pType(kI) As DWord At Me.pTypes
Function = HEAP_Get(pType(kI))
End Function
'---------------------------------------------------------------------------------
Function tTypedHeap.GetData( Optional ByVal Index As Long, _
ByVal sSeperator As String _
) As String
'---------------------------------------------------------------------------------
' returns element(Index)-data
Local kI As Long = Me.GetKeyIndex(TRUE)
If Not kI Then Exit Function
Local pType(kI) As DWord At Me.pTypes
If Not HEAP_Size(Me.pData) Then Exit Function
If HEAP_Get(pType(kI)) = "STRING" Then
If Between(Index, 1, Me.GetUBound ) Then
Local pData As DWord At Me.pData + (Index-1) * 4
Function = HEAP_Get(pData)
Else
Local pData As DWord At Me.pData
Local sResult As String
Do
sResult &= HEAP_Get(pData) & sSeperator
SetAt(pData, VarPtr(pData) + 4 )
Loop Until GetAt(pData) > HEAP_End(Me.pData)
Function = sResult
EndIf
Else
If Between(Index, 1, Me.GetUBound ) Then
Local data(Index) Like HEAP_Get(pType(kI)) At Me.pData
Function = data(Index)
Else
Function = HEAP_Get(Me.pData)
EndIf
EndIf
End Function
'---------------------------------------------------------------------------------
Function tTypedHeap.GetUBound() As Long
'---------------------------------------------------------------------------------
' returns UBound of stored elements
If HEAP_Size(Me.pData) = 0 Then Return 0
Local kI As Long = Me.GetKeyIndex(TRUE)
If Not kI Then Return 0
Local pType(kI) As DWord At Me.pTypes
If HEAP_Get(pType(kI)) = "STRING" Then
Function = HEAP_Size(Me.pData)/4
Else
Local data Like HEAP_Get(pType(kI)) At Me.pData
Function = HEAP_Size(Me.pData)/SizeOf(data)
EndIf
End Function
'---------------------------------------------------------------------------------
Function tTypedHeap.SetData(ByVal sData As String, _
Optional ByVal Index As Long = 1 _
) As DWord
'---------------------------------------------------------------------------------
' returns pointer where exactly to read this data if success
If HEAP_Size(Me.pData) = 0 Then Return 0
Local kI As Long = Me.GetKeyIndex(TRUE)
If Not kI Then Return 0
Local pType(kI) As DWord At Me.pTypes
If HEAP_Get(pType(kI)) = "STRING" Then
Local pData(Index) As DWord At Me.pData
pData(Index) = HEAP_ReAllocByStr(pData(Index), sData)
Function = pData(Index)
Else
If Function_CParams = 2 Then
Select Case HEAP_Get(pType(kI))
Case "BYTE"
sData = MKBYT$(sData)
Case "INTEGER", "BOOLEAN"
sData = MKI$(sData)
Case "WORD"
sData = MKWRD$(sData)
Case "DWORD"
sData = MKDWD$(sData)
Case "LONG"
sData = MKL$(sData)
Case "QUAD"
sData = MKQ$(sData)
Case "EXT", "EXTENDED"
sData = MKE$(sData)
Case "CURRENCY"
sData = MKCUR$(sData)
Case "SINGLE"
sData = MKS$(sData)
Case "DOUBLE"
sData = MKD$(sData)
End Select
Local data Like HEAP_Get(pType(kI)) At 0
SetAt(data, Me.pData + (Index-1) * SizeOf(data) )
Memory_Set( GetAt(data), sData)
Function = GetAt(data)
Else
Me.pData = HEAP_ReAllocByStr(Me.pData, sData)
Function = Me.pData
EndIf
EndIf
End Function
'---------------------------------------------------------------------------------
Function tTypedHeap.AddData(ByVal sData As String) As DWord
'---------------------------------------------------------------------------------
' returns new pointer on success or 0 if fails
Local kI As Long = Me.GetKeyIndex(TRUE)
If Not kI Then Return 0
Local pType(kI) As DWord At Me.pTypes
If HEAP_Get(pType(kI)) = "STRING" Then
Me.pData = HEAP_ReAllocByStr(Me.pData, HEAP_Get(Me.pData) & MKDWD$(HEAP_AllocByStr(sData)) )
If HEAP_Size(Me.pData) Then Function = Peek(DWord, HEAP_End(Me.pData) - 3 )
Else
Select Case HEAP_Get(pType(kI))
Case "BYTE"
If StrPtrLen(StrPtr(sData)) = Len(CVBYT(MKBYT$(sData))) Then sData = MKBYT$(sData)
Case "INTEGER", "BOOLEAN"
If StrPtrLen(StrPtr(sData)) = Len(CVI(MKI$(sData))) Then sData = MKI$(sData)
Case "WORD"
If StrPtrLen(StrPtr(sData)) = Len(CVWRD(MKWRD$(sData))) Then sData = MKWRD$(sData)
Case "DWORD"
If StrPtrLen(StrPtr(sData)) = Len(CVDWD(MKDWD$(sData))) Then sData = MKDWD$(sData)
Case "LONG"
If StrPtrLen(StrPtr(sData)) = Len(CVL(MKL$(sData))) Then sData = MKL$(sData)
Case "QUAD"
If StrPtrLen(StrPtr(sData)) = Len(CVQ( MKQ$(sData))) Then sData = MKQ$(sData)
Case "EXT", "EXTENDED"
If StrPtrLen(StrPtr(sData)) = Len(CVE(MKE$(sData))) Then sData = MKE$(sData)
Case "CURRENCY"
If StrPtrLen(StrPtr(sData)) = Len(CVCUR(MKCUR$(sData))) Then sData = MKCUR$(sData)
Case "SINGLE"
If StrPtrLen(StrPtr(sData)) = Len(CVS(MKS$(sData))) Then sData = MKS$(sData)
Case "DOUBLE"
If StrPtrLen(StrPtr(sData)) = Len(CVD(MKD$(sData))) Then sData = MKD$(sData)
End Select
Me.pData = HEAP_ReAllocByStr(Me.pData, HEAP_Get(Me.pData) & sData )
Function = Me.pData
EndIf
End Function
'---------------------------------------------------------------------------------
Function tTypedHeap.Load(ByVal sFilename As String) As String
'---------------------------------------------------------------------------------
Local kI As Long = Me.GetKeyIndex()
Local pType(kI) As DWord At Me.pTypes
If HEAP_Size(Me.pData) Then Me.Free()
Local sData As String = Load_File(sFilename)
If StrPtrLen(StrPtr(sData)) < 4 Then Return "byte"
Local lLen As Long At StrPtr(sData)
Local sType As String = Memory_Get(StrPtr(sData)+4, lLen)
Local lPos As Long
pType(kI) = Type_Enumerate(sType)
If Ucase$(sType) = "STRING" Then
SetAt( lLen, VarPtr(lLen) + 4 + lLen )
While GetAt(lLen) < StrPtr(sData) + StrPtrLen(StrPtr(sData))
Me.AddData( Memory_Get( VarPtr(lLen) + 4, lLen) )
SetAt( lLen, VarPtr(lLen) + 4 + lLen )
Wend
Function = "DWORD"
Else
SetAt( lLen, VarPtr(lLen) + 4 + lLen )
Me.AllocByStr( Memory_Get( VarPtr(lLen) + 4, lLen) )
Function = HEAP_Get(pType(kI))
EndIf
End Function
'---------------------------------------------------------------------------------
Function tTypedHeap.Save(ByVal sFilename As String) As Boolean
'---------------------------------------------------------------------------------
Local kI As Long = Me.GetKeyIndex(TRUE)
If Not kI Then Return FALSE
Local pType(kI) As DWord At Me.pTypes
Local sOut As String
If HEAP_Get(pType(kI))= "STRING" then
sOut = MKL$(HEAP_Size(pType(kI))) _
& HEAP_Get(pType(kI))
Local pLine As DWord At Me.pData
Do
sOut &= MKL$(HEAP_Size(pLine)) _
& HEAP_Get(pLine)
SetAt(pLine, VarPtr(pLine) + 4 )
Loop Until GetAt(pLine) >= HEAP_End(Me.pData)
Else
sOut = MKL$(HEAP_Size(pType(kI))) _
& HEAP_Get(pType(kI)) _
& MKL$(HEAP_Size(Me.pData)) _
& HEAP_Get(Me.pData)
EndIf
Function = ( Save_File( sFilename, sOut ) = 0 )
End Function
'---------------------------------------------------------------------------------
'Function tTypedHeap.()
'---------------------------------------------------------------------------------
'End Function
and some testing-script, syntax examples:
#MINVERSION 1.9.15.0
Uses "console"
#INCLUDE Once "tHeap.tBasicU"
Dim h, p As tHeap
Dim i As Long
PrintL "Testing primitive tHeap-Type"
If h.AllocByStr("1234567890") Then
PrintL "h.AllocByStr(" & $DQ & "1234567890" & $DQ & ")"
PrintL "We have" & Str$(h.GetSize) & " Bytes" & $CRLF
PrintL "h.GetBytes"
'(first, count)
PrintL "all : " & h.GetBytes() ' all
PrintL "1, 3 : " & h.GetBytes( 1, 3) ' left 3
PrintL "4, 4 : " & h.GetBytes( 4, 4) ' mid 4, 4
PrintL " , 5 : " & h.GetBytes( , 5) ' right 5
PrintL "7, : " & h.GetBytes( 7 ) ' all from 7
PrintL
If p.Copy(h) Then
PrintL "test .copy :" & p.GetData
EndIf
h.Free
PrintL "check h after free: " & $DQ & h.GetBytes & $DQ
PrintL
p.Save(APP_ScriptPath & "test.dat")
PrintL "saved p"
If h.Load(APP_ScriptPath & "test.dat") Then
PrintL "check h after load: " & $DQ & h.GetBytes & $DQ
PrintL
h.Free
EndIf
PrintL "test h.Alloc(25):"
If h.Alloc(25) Then
PrintL "and have" & Str$(h.GetSize) & " Bytes" & $CRLF
' quick fill via layover:
Local b(h.GetSize) As Byte At h.pData
For i = 1 To UBound(b)
b(i) = 64 + i ' ABC...
Next
PrintL h.GetBytes
Else
PrintL "h.Alloc failed"
EndIf
PrintL "test h.ReAlloc(15):"
If h.ReAlloc(15) Then
PrintL "now have" & Str$(h.GetSize) & " Bytes" & $CRLF
PrintL h.GetBytes
Else
PrintL "h.ReAlloc failed"
EndIf
Else
PrintL "h.AllocByStr failed!"
EndIf
PrintL $CRLF & "key to continue"
WaitKey
h.Free()
p.Free()
' typed heap will work with any numeric type, dynamic strings and udts
' all data is treated as dynamic array by default
PrintL $CRLF & "now testing tTypedHeap"
Dim th As tTypedHeap
PrintL $CRLF & "allocating space for 8 longs"
th.AllocAs("Long", 8)
PrintL "fill with data using .SetData"
For i = 1 To th.GetUbound
' ( value , Index)
th.SetData( Pow(2, i-1), i )
Next
PrintL "adding some seperate elements"
' negative values only work as variable or in quotes!
' the minus seems to irritate the parser...
th.AddData( "-12345" )
i = -45678
th.AddData( i )
' can also add multiple elements at once using type-conversion:
th.AddData( MKL$(-11,-12,-13) )
PrintL "request all elements:"
For i = 1 To th.GetUbound
PrintL "Element(" & TStr$(i) & ") = " & th.GetData(i)
Next
PrintL $CRLF & "key to continue"
WaitKey
PrintL $CRLF & "overwrite th with 5 strings,"
th.AllocAs("String", 5 )
PrintL ".SetData for Elements 1 to 5"
th.SetData("I am first string", 1)
th.SetData("second string", 2)
th.SetData("third string", 3)
th.SetData("string four", 4)
th.SetData("and five", 5)
PrintL $CRLF & "append more strings using .AddData"
th.AddData("one more added")
th.AddData("how about this?")
PrintL $CRLF & "request all data-elements seperated by $CRLF:"
PrintL th.GetData( , $CRLF)
PrintL $CRLF & "key to continue"
WaitKey
PrintL "save the stuff..."
th.Save(APP_ScriptPath & "thSaveTest.dat")
PrintL $CRLF & "key to continue"
WaitKey
PrintL "allocate as other type & instantly fill in data"
' Ubound does not matter as long as it's smaller than passed data
th.AllocAs("Long", , MKL$(5,4,3,2,1) )
For i = 1 To th.GetUbound
PrintL "Element(" & TStr$(i) & ") = " & th.GetData(i)
Next
PrintL $CRLF & "now .setData(data, omitted Index)"
th.SetData(MKL$(1,2,3))
For i = 1 To th.GetUbound
PrintL "Element(" & TStr$(i) & ") = " & th.GetData(i)
Next
PrintL "altogether: " & th.GetData()
PrintL "now smile :)"
th.Free()
PrintL $CRLF & "key to continue"
WaitKey
PrintL "now reload th (multiple strings)"
th.Load(APP_ScriptPath & "thSaveTest.dat")
PrintL "output: " & $CRLF & th.GetData( , $CRLF)
PrintL $CRLF & "key to end"
WaitKey
Reply With Quote
I think there are missing some Forum-sections as beta-testing and support
Originally Posted by Petr Schreiber
This is great Rene,
Members who have read this thread: 0
Bookmarks