Skip to content

Commit ec6aefc

Browse files
jayrmjayrm
committed
fbdocs: wiki snapshot 2023.05.06 - update ./examples/manual
1 parent 1b29541 commit ec6aefc

File tree

11 files changed

+1469
-598
lines changed

11 files changed

+1469
-598
lines changed

‎examples/manual/operator/procptr3.bas‎

Lines changed: 86 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,86 @@
1+
'' examples/manual/operator/procptr3.bas
2+
''
3+
'' Example extracted from the FreeBASIC Manual
4+
'' from topic 'Operator PROCPTR (Procedure pointer and vtable index)'
5+
''
6+
'' See Also: https://www.freebasic.net/wiki/wikka.php?wakka=KeyPgOpProcptr
7+
'' --------
8+
9+
' Since fbc 1.10.0, ProcPtr supports the member procedures/operators with various syntaxes
10+
11+
Type UDT Extends Object
12+
Dim As String s1
13+
Dim As String s2
14+
Declare Virtual Sub test()
15+
Declare Virtual Operator Cast() As String
16+
End Type
17+
18+
Sub UDT.test()
19+
Print This.s1
20+
End Sub
21+
22+
Operator UDT.Cast() As String
23+
Return This.s2
24+
End Operator
25+
26+
Var testPtr1 = ProcPtr(UDT.test)
27+
Var testPtr2 = ProcPtr(UDT.test, Any)
28+
Var testPtr3 = ProcPtr(UDT.test, Sub())
29+
30+
Dim As Function(ByRef As UDT) As String castPtr1 = ProcPtr(UDT.cast)
31+
Dim As Function(ByRef As UDT) As String castPtr2 = ProcPtr(UDT.cast, Any)
32+
Dim As Function(ByRef As UDT) As String castPtr3 = ProcPtr(UDT.cast, Function() As String)
33+
34+
Var testIndex1 = ProcPtr(UDT.test, Virtual)
35+
Var testIndex2 = ProcPtr(UDT.test, Virtual Any)
36+
Var testIndex3 = ProcPtr(UDT.test, Virtual Sub())
37+
38+
Dim As Integer castIndex1 = ProcPtr(UDT.cast, Virtual)
39+
Dim As Integer castIndex2 = ProcPtr(UDT.cast, Virtual Any)
40+
Dim As Integer castIndex3 = ProcPtr(UDT.cast, Virtual Function() As String)
41+
42+
Print testPtr1 '' absolue address value of UDT.test pointer
43+
Print testPtr2 '' absolue address value of UDT.test pointer
44+
Print testPtr3 '' absolue address value of UDT.test pointer
45+
Print
46+
47+
Print castPtr1 '' absolue address value of UDT.Cast pointer
48+
Print castPtr2 '' absolue address value of UDT.Cast pointer
49+
Print castPtr3 '' absolue address value of UDT.Cast pointer
50+
Print
51+
52+
Print testIndex1 '' vtable index of UDT.test
53+
Print testIndex2 '' vtable index of UDT.test
54+
Print testIndex3 '' vtable index of UDT.test
55+
Print
56+
57+
Print castIndex1 '' vtable index of UDT.Cast
58+
Print castIndex2 '' vtable index of UDT.Cast
59+
Print castIndex3 '' vtable index of UDT.Cast
60+
Print
61+
62+
Dim As UDT u
63+
u.s1 = "Virtual Sub test()"
64+
u.s2 = "Virtual Operator Cast() As String"
65+
66+
testPtr1(u) '' execute u.test() through its procedure pointer
67+
testPtr2(u) '' execute u.test() through its procedure pointer
68+
testPtr3(u) '' execute u.test() through its procedure pointer
69+
Print
70+
71+
Print castPtr1(u) '' execute Cast(UDT, u) through its procedure pointer
72+
Print castPtr2(u) '' execute Cast(UDT, u) through its procedure pointer
73+
Print castPtr3(u) '' execute Cast(UDT, u) through its procedure pointer
74+
Print
75+
76+
CPtr(Sub(ByRef As UDT), CPtr(Any Ptr Ptr Ptr, @u)[0][testIndex1])(u) '' execute u.test() through its vtable index
77+
CPtr(Sub(ByRef As UDT), CPtr(Any Ptr Ptr Ptr, @u)[0][testIndex2])(u) '' execute u.test() through its vtable index
78+
CPtr(Sub(ByRef As UDT), CPtr(Any Ptr Ptr Ptr, @u)[0][testIndex3])(u) '' execute u.test() through its vtable index
79+
Print
80+
81+
Print CPtr(Function(ByRef As UDT) As String, CPtr(Any Ptr Ptr Ptr, @u)[0][castIndex1])(u) '' execute Cast(UDT, u) through its vtable index
82+
Print CPtr(Function(ByRef As UDT) As String, CPtr(Any Ptr Ptr Ptr, @u)[0][castIndex2])(u) '' execute Cast(UDT, u) through its vtable index
83+
Print CPtr(Function(ByRef As UDT) As String, CPtr(Any Ptr Ptr Ptr, @u)[0][castIndex3])(u) '' execute Cast(UDT, u) through its vtable index
84+
Print
85+
86+
Sleep

‎examples/manual/operator/procptr4.bas‎

Lines changed: 47 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,47 @@
1+
'' examples/manual/operator/procptr4.bas
2+
''
3+
'' Example extracted from the FreeBASIC Manual
4+
'' from topic 'Operator PROCPTR (Procedure pointer and vtable index)'
5+
''
6+
'' See Also: https://www.freebasic.net/wiki/wikka.php?wakka=KeyPgOpProcptr
7+
'' --------
8+
9+
' Since fbc 1.10.0, ProcPtr allows to access the vtable index of a virtual/abstract member procedure/operator
10+
11+
Type Parent Extends Object
12+
Declare Abstract Sub test()
13+
Declare Virtual Operator Cast() As String
14+
End Type
15+
16+
Operator Parent.Cast() As String
17+
Return "Parent.Cast() As String"
18+
End Operator
19+
20+
Type Child Extends Parent
21+
Declare Virtual Sub test() '' or Declare Sub test()
22+
Declare Virtual Operator Cast() As String '' or Declare Operator Cast() As String
23+
End Type
24+
25+
Sub Child.test()
26+
Print "Child.test()"
27+
End Sub
28+
29+
Operator Child.Cast() As String
30+
Return "Child.Ccast() As String"
31+
End Operator
32+
33+
Dim As Parent Ptr p = New Child
34+
p->test()
35+
Print Cast(Parent, *p) '' or Print *p
36+
Print
37+
38+
#define VirtProcPtr(instance, procedure) CPtr(TypeOf(ProcPtr(procedure)), _ '' pointer to virtual procedure
39+
CPtr(Any Ptr Ptr Ptr, @(instance)) _ '' (the most derived override that exists)
40+
[0][ProcPtr(procedure, Virtual)])
41+
42+
VirtProcPtr(*p, Parent.test)(*p) '' execute p->test() through its vtable index
43+
Print VirtProcPtr(*p, Parent.Cast)(*p) '' execute Cast(Parent, *p) through its vtable index
44+
Print
45+
46+
Delete p
47+
Sleep

‎examples/manual/proguide/multithreading/criticalsectionfaq12.bas‎

Lines changed: 42 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,9 @@
11
'' examples/manual/proguide/multithreading/criticalsectionfaq12.bas
22
''
33
'' Example extracted from the FreeBASIC Manual
4-
'' from topic 'Critical Sections FAQ'
4+
'' from topic 'Emulate a TLS (Thread Local Storage) and a TP (Thread Pooling) feature'
55
''
6-
'' See Also: https://www.freebasic.net/wiki/wikka.php?wakka=ProPgMtCriticalSectionsFAQ
6+
'' See Also: https://www.freebasic.net/wiki/wikka.php?wakka=ProPgEmulateTlsTp
77
'' --------
88

99
#include Once "crt/string.bi"
@@ -23,41 +23,43 @@
2323
#macro CreateTLSdatatypeVariableFunction (variable_function_name, variable_datatype)
2424
' Creation of a "variable_function_name" function to emulate a static datatype variable (not an array),
2525
' with a value depending on the thread using it.
26-
Function variable_function_name (ByVal cd As Boolean = True) ByRef As variable_datatype
27-
' Function emulating (creation/access/destruction) a static datatype variable with value depending on thread using it:
28-
' If calling without parameter (or with 'True') parameter, this allows to [create and] access the static datatype variable.
29-
' If calling with the 'False' parameter, this allows to destroy the static datatype variable.
30-
Dim As Integer bound = 0
31-
Static As Any Ptr TLSindex(bound)
32-
Static As variable_datatype TLSdata(bound)
33-
Dim As Any Ptr Threadhandle = ThreadSelf()
34-
Dim As Integer index = 0
35-
For I As Integer = 1 To UBound(TLSindex) ' search existing TLS variable (existing array element) for the running thread
36-
If TLSindex(I) = Threadhandle Then
37-
index = I
38-
Exit For
26+
Namespace TLS
27+
Function variable_function_name (ByVal cd As Boolean = True) ByRef As variable_datatype
28+
' Function emulating (creation/access/destruction) a static datatype variable with value depending on thread using it:
29+
' If calling without parameter (or with 'True') parameter, this allows to [create and] access the static datatype variable.
30+
' If calling with the 'False' parameter, this allows to destroy the static datatype variable.
31+
Dim As Integer bound = 0
32+
Static As Any Ptr TLSindex(bound)
33+
Static As variable_datatype TLSdata(bound)
34+
Dim As Any Ptr Threadhandle = ThreadSelf()
35+
Dim As Integer index = 0
36+
For I As Integer = 1 To UBound(TLSindex) ' search existing TLS variable (existing array element) for the running thread
37+
If TLSindex(I) = Threadhandle Then
38+
index = I
39+
Exit For
40+
End If
41+
Next I
42+
If index = 0 And cd = True Then ' create a new TLS variable (new array element) for a new thread
43+
index = UBound(TLSindex) + 1
44+
ReDim Preserve TLSindex(index)
45+
TLSindex(index) = Threadhandle
46+
ReDim Preserve TLSdata(index)
47+
ElseIf index > 0 And cd = False Then ' destroy a TLS variable (array element) and compact the array
48+
If index < UBound(TLSindex) Then ' reorder the array elements
49+
memmove(@TLSindex(index), @TLSindex(index + 1), (UBound(TLSindex) - index) * SizeOf(Any Ptr))
50+
Dim As variable_datatype Ptr p = Allocate(SizeOf(variable_datatype)) ' for compatibility to object with destructor
51+
memmove(p, @TLSdata(index), SizeOf(variable_datatype)) ' for compatibility to object with destructor
52+
memmove(@TLSdata(index), @TLSdata(index + 1), (UBound(TLSdata) - index) * SizeOf(variable_datatype))
53+
memmove(@TLSdata(UBound(TLSdata)), p, SizeOf(variable_datatype)) ' for compatibility to object with destructor
54+
Deallocate(p) ' for compatibility to object with destructor
55+
End If
56+
ReDim Preserve TLSindex(UBound(TLSindex) - 1)
57+
ReDim Preserve TLSdata(UBound(TLSdata) - 1)
58+
index = 0
3959
End If
40-
Next I
41-
If index = 0 And cd = True Then ' create a new TLS variable (new array element) for a new thread
42-
index = UBound(TLSindex) + 1
43-
ReDim Preserve TLSindex(index)
44-
TLSindex(index) = Threadhandle
45-
ReDim Preserve TLSdata(index)
46-
ElseIf index > 0 And cd = False Then ' destroy a TLS variable (array element) and compact the array
47-
If index < UBound(TLSindex) Then ' reorder the array elements
48-
memmove(@TLSindex(index), @TLSindex(index + 1), (UBound(TLSindex) - index) * SizeOf(Any Ptr))
49-
Dim As variable_datatype Ptr p = Allocate(SizeOf(variable_datatype)) ' for compatibility to object with destructor
50-
memmove(p, @TLSdata(index), SizeOf(variable_datatype)) ' for compatibility to object with destructor
51-
memmove(@TLSdata(index), @TLSdata(index + 1), (UBound(TLSdata) - index) * SizeOf(variable_datatype))
52-
memmove(@TLSdata(UBound(TLSdata)), p, SizeOf(variable_datatype)) ' for compatibility to object with destructor
53-
Deallocate(p) ' for compatibility to object with destructor
54-
End If
55-
ReDim Preserve TLSindex(UBound(TLSindex) - 1)
56-
ReDim Preserve TLSdata(UBound(TLSdata) - 1)
57-
index = 0
58-
End If
59-
Return TLSdata(index)
60-
End Function
60+
Return TLSdata(index)
61+
End Function
62+
End Namespace
6163
#endmacro
6264

6365
'------------------------------------------------------------------------------
@@ -75,11 +77,11 @@ End Type
7577
Dim As Any Ptr threadData.mutex
7678
#endif
7779

78-
CreateTLSdatatypeVariableFunction (TLScount, Integer) ' create a TLS static integer function
80+
CreateTLSdatatypeVariableFunction (count, Integer) ' create a TLS static integer function
7981

8082
Function counter() As Integer ' definition of a generic counter with counting depending on thread calling it
81-
TLScount() += 1 ' increment the TLS static integer
82-
Return TLScount() ' return the TLS static integer
83+
TLS.count() += 1 ' increment the TLS static integer
84+
Return TLS.count() ' return the TLS static integer
8385
End Function
8486

8587
Sub Thread(ByVal p As Any Ptr)
@@ -101,7 +103,7 @@ Sub Thread(ByVal p As Any Ptr)
101103
MutexLock(threadData.mutex)
102104
ThreadSelf() = ptd->handle
103105
#endif
104-
TLScount(False) ' destroy the TLS static integer
106+
TLS.count(False) ' destroy the TLS static integer
105107
#if __FB_VERSION__ < "1.08"
106108
MutexUnlock(threadData.mutex)
107109
#endif

0 commit comments

Comments
 (0)