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:
and some testing-script, syntax examples:#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
#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
I think there are missing some Forum-sections as beta-testing and support 
Reply With Quote
Bookmarks