source: trunk/Include/system/exception.ab@ 388

Last change on this file since 388 was 388, checked in by イグトランス (egtra), 17 years ago

Stringなどで例外を投げるようにした。
#147の解決。
CType ASCII文字判定関数群の追加。

File size: 5.1 KB
Line 
1'TODO: ローカルオブジェクト確保及び解放時にTryServiceに通知する必要がある。
2
3Class TryLayer
4Public
5 Const catchTable As *LONG_PTR
6 Const addressOfFinally As VoidPtr
7 Const basePtr As LONG_PTR
8 Const stackPtr As LONG_PTR
9
10 Const debugProcNum As DWord
11
12 Sub TryLayer( catchTable As *LONG_PTR, addressOfFinally As VoidPtr, basePtr As LONG_PTR, stackPtr As LONG_PTR )
13 This.catchTable = catchTable
14 This.addressOfFinally = addressOfFinally
15 This.basePtr = basePtr
16 This.stackPtr = stackPtr
17
18#ifdef _DEBUG
19 Dim ThreadNum As Long
20 ThreadNum=_DebugSys_GetThread()
21 If ThreadNum <> -1 Then
22 debugProcNum = _DebugSys_ProcNum[ThreadNum]
23 End If
24#endif
25 End Sub
26 Sub ~TryLayer()
27 End Sub
28
29 Sub FinishFinally()
30 If Thread.CurrentThread().__IsThrowing() Then
31 Throw Thread.CurrentThread().__GetThrowintParamObject()
32 End If
33 End Sub
34
35 Function ResolveCatchesOverload( ex As Object ) As LONG_PTR
36 Dim defaultCatchCodePos = 0 As LONG_PTR
37 Dim pos = 0 As Long
38 While catchTable[pos]
39 ' パラメータのクラス名
40 Dim paramName = catchTable[pos] As *Char
41 pos ++
42
43 ' コード位置
44 Dim codePos = catchTable[pos] As LONG_PTR
45 pos ++
46
47 If paramName[0] = 0 Then
48 ' Default Catch
49 defaultCatchCodePos = codePos
50 End If
51
52 If Object.ReferenceEquals( ex, Nothing ) Then
53 ' パラメータなしのとき
54 If paramName[0] = 0 Then
55 ' マッチしたとき
56 Return codePos
57 End If
58 Else
59 If isCatchable(New String(paramName), ex.GetType()) Then
60' If lstrcmp( paramName, ex.GetType().FullName ) = 0 Then
61 ' マッチしたとき
62 Return codePos
63 End If
64 End If
65 Wend
66 Return defaultCatchCodePos
67 End Function
68
69 Function isCatchable(paramName As String, catchType As System.TypeInfo) As Boolean
70 isCatchable = False
71 While Not ActiveBasic.IsNothing(catchType)
72 Dim catchTypeName = catchType.FullName
73 If paramName = catchTypeName Then
74 isCatchable = True
75 Exit Function
76 End If
77 catchType = catchType.BaseType
78 Wend
79 End Function
80End Class
81
82Class ExceptionService
83 ppTryLayers As **TryLayer
84 nTryLayers As Long
85
86 Sub FreeLocalObjects()
87 'TODO: 破棄されていないローカルオブジェクトを破棄
88 End Sub
89Public
90
91 Sub ExceptionService()
92 ppTryLayers = _System_malloc( 1 )
93 nTryLayers = 0
94 End Sub
95 Sub ~ExceptionService()
96 Dim i As Long
97 For i = 0 To ELM( nTryLayers )
98 Delete ppTryLayers[i]
99 Next
100 _System_free( ppTryLayers )
101 ppTryLayers = 0
102 End Sub
103
104 'Try
105 Function _BeginTryScope( catchTable As *LONG_PTR, addressOfFinally As VoidPtr, basePtr As LONG_PTR, stackPtr As LONG_PTR ) As TryLayer
106 ppTryLayers = _System_realloc( ppTryLayers, ( nTryLayers + 1 ) * SizeOf( *TryLayer ) )
107 ppTryLayers[nTryLayers] = New TryLayer( catchTable, addressOfFinally, basePtr, stackPtr )
108 nTryLayers++
109
110 Return ByVal ppTryLayers[nTryLayers-1]
111 End Function
112
113 Static Function BeginTryScope( catchTable As *LONG_PTR, addressOfFinally As VoidPtr, basePtr As LONG_PTR, stackPtr As LONG_PTR ) As TryLayer
114 Return _System_pobj_AllThreads->GetCurrentException()->_BeginTryScope( catchTable, addressOfFinally, basePtr, stackPtr )
115 End Function
116
117 'End Try
118 Sub EndTryScope()
119 nTryLayers--
120 Delete ppTryLayers[nTryLayers]
121 End Sub
122
123 'Throw
124 Sub _Throw( ex As Object )
125 If nTryLayers <= 0 then
126 '例外処理スコープ制御が無効なとき
127
128 'TODO: 適切なエラー処理
129 MessageBox( NULL, "Catchされていない例外があります", NULL, MB_OK or MB_ICONEXCLAMATION )
130 Debug
131 Return
132 End If
133
134 ' スレッドへThrow処理を開始したことを通知
135 Thread.CurrentThread().__Throw( ex )
136
137 '未解放なローカルオブジェクトを解放する
138 FreeLocalObjects()
139
140 Dim pTryLayer = ppTryLayers[nTryLayers - 1] As *TryLayer
141
142 Dim addressOfCatch = pTryLayer->ResolveCatchesOverload( ex ) As LONG_PTR
143 If addressOfCatch = NULL Then
144 ' Catchが定義されていないときはFinallyへ誘導
145 addressOfCatch = pTryLayer->addressOfFinally As LONG_PTR
146 End If
147
148
149 '--------------------------------------------------
150 ' スレッドのコンテキストを設定(Catchへ遷移する)
151 '--------------------------------------------------
152
153 Dim context As CONTEXT
154 context.ContextFlags = CONTEXT_CONTROL or CONTEXT_INTEGER
155 If GetThreadContext( GetCurrentThread(), context ) = 0 Then
156 ' TODO: エラー処理
157 debug
158 End If
159
160 '新しいip, sp, bpをセット
161#ifdef _WIN64
162 context.Rip = addressOfCatch As QWord
163 context.Rbp = pTryLayer->basePtr
164 context.Rsp = pTryLayer->stackPtr
165#else
166 context.Eip = addressOfCatch As DWord
167 context.Ebp = pTryLayer->basePtr
168 context.Esp = pTryLayer->stackPtr
169#endif
170
171#ifdef _DEBUG
172 Dim ThreadNum As Long
173 ThreadNum=_DebugSys_GetThread()
174 If ThreadNum <> -1 Then
175 _DebugSys_ProcNum[ThreadNum] = pTryLayer->debugProcNum-1
176 End If
177#endif
178
179 If SetThreadContext( GetCurrentThread(), context ) = 0 Then
180 OutputDebugString(Ex"レジスタ情報の設定に失敗しました。\r\n")
181 Return
182 End If
183 End Sub
184
185 Sub _ThrowWithParam( ex As Object )
186 _Throw( ex )
187 End Sub
188
189 Sub _ThrowNoneParam()
190 _Throw( Nothing )
191 End Sub
192
193 Sub FinishFinally()
194 Dim pTryLayer = ppTryLayers[nTryLayers - 1] As *TryLayer
195 pTryLayer->FinishFinally()
196 End Sub
197End Class
198
Note: See TracBrowser for help on using the repository browser.