'TODO: ローカルオブジェクト確保及び解放時にTryServiceに通知する必要がある。

Class TryLayer
Public
	Const catchTable As *LONG_PTR
	Const addressOfFinally As VoidPtr
	Const basePtr As LONG_PTR
	Const stackPtr As LONG_PTR

	Const debugProcNum As DWord
	
	Sub TryLayer( catchTable As *LONG_PTR, addressOfFinally As VoidPtr, basePtr As LONG_PTR, stackPtr As LONG_PTR )
		This.catchTable = catchTable
		This.addressOfFinally = addressOfFinally
		This.basePtr = basePtr
		This.stackPtr = stackPtr

#ifdef _DEBUG
		Dim ThreadNum As Long
		ThreadNum=_DebugSys_GetThread()
		If ThreadNum <> -1 Then
			debugProcNum = _DebugSys_ProcNum[ThreadNum]
		End If
#endif
	End Sub
	Sub ~TryLayer()
	End Sub

	Sub FinishFinally()
		Imports System.Threading
		If Thread.CurrentThread().__IsThrowing() Then
			Throw Thread.CurrentThread().__GetThrowintParamObject()
		End If
	End Sub

	Function ResolveCatchesOverload( ex As Object ) As LONG_PTR
		OutputDebugString("ResolveCatchesOverload: ")
		OutputDebugString(ToTCStr(ex.ToString))
		OutputDebugString(Ex"\r\n")
		Dim defaultCatchCodePos = 0 As LONG_PTR
		Dim pos = 0 As Long
		While catchTable[pos]
			' パラメータのクラス名
			Dim paramName = catchTable[pos] As *Char
			pos ++

			' コード位置
			Dim codePos = catchTable[pos] As LONG_PTR
			pos ++

			If paramName[0] = 0 Then
				' Default Catch
				defaultCatchCodePos = codePos
			End If

			If Object.ReferenceEquals( ex, Nothing ) Then
				' パラメータなしのとき
				If paramName[0] = 0 Then
					' マッチしたとき
					Return codePos
				End If
			Else
				If isCatchable(New String(paramName), ex.GetType()) Then
'				If lstrcmp( paramName, ex.GetType().FullName ) = 0 Then
					' マッチしたとき
					Return codePos
				End If
			End If
		Wend
		Return defaultCatchCodePos
	End Function
Private
	Function isCatchable(paramName As String, catchType As System.TypeInfo) As Boolean
/*		If Not String.IsNullOrEmpty(paramName) Then
			Dim paramType = _System_TypeBase_Search(paramName)
			isCatchable = ActiveBasic.Detail.IsBaseOf(catchType, paramType)
		Else
			isCatchable = False
		End If
/*/
		isCatchable = False
		While Not ActiveBasic.IsNothing(catchType)
			Dim catchTypeName = catchType.FullName
			If paramName = catchTypeName Then
				isCatchable = True
				Exit Function
			End If
			catchType = catchType.BaseType
		Wend
'*/
	End Function
End Class

Class ExceptionService
	tryLayers As System.Collections.Generic.List<TryLayer>

	Sub FreeLocalObjects()
		'TODO: 破棄されていないローカルオブジェクトを破棄
	End Sub
Public

	Sub ExceptionService()
		tryLayers = New System.Collections.Generic.List<TryLayer>
	End Sub
	Sub ~ExceptionService()
	End Sub

	'Try
	Function _BeginTryScope( catchTable As *LONG_PTR, addressOfFinally As VoidPtr, basePtr As LONG_PTR, stackPtr As LONG_PTR ) As TryLayer
		Dim tryLayer = New TryLayer( catchTable, addressOfFinally, basePtr, stackPtr )
		tryLayers.Add( tryLayer )

		Return tryLayer
	End Function

	Static Function BeginTryScope( catchTable As *LONG_PTR, addressOfFinally As VoidPtr, basePtr As LONG_PTR, stackPtr As LONG_PTR ) As TryLayer
		Return _System_pobj_AllThreads->GetCurrentException()._BeginTryScope( catchTable, addressOfFinally, basePtr, stackPtr )
	End Function

	'End Try
	Sub EndTryScope()
		tryLayers.RemoveAt( tryLayers.Count - 1 )
	End Sub

	'Throw
	Sub _Throw( ex As Object )
		If tryLayers.Count <= 0 then
			'例外処理スコープ制御が無効なとき

			'TODO: 適切なエラー処理
			System.Diagnostics.Debug.WriteLine( Ex"Catchされていない例外があります\r\n" + ex.ToString )
			MessageBox( NULL, ToTCStr(Ex"Catchされていない例外があります\r\n" + ex.ToString), NULL, MB_OK or MB_ICONEXCLAMATION )
			Debug
			Return
		End If

		' スレッドへThrow処理を開始したことを通知
		Imports System.Threading
		Thread.CurrentThread().__Throw( ex )

		'未解放なローカルオブジェクトを解放する
		FreeLocalObjects()

		Dim tryLayer = tryLayers[tryLayers.Count - 1]

		Dim addressOfCatch = tryLayer.ResolveCatchesOverload( ex ) As LONG_PTR
		If addressOfCatch = NULL Then
			' Catchが定義されていないときはFinallyへ誘導
			addressOfCatch = tryLayer.addressOfFinally As LONG_PTR
		End If


		'--------------------------------------------------
		' スレッドのコンテキストを設定（Catchへ遷移する）
		'--------------------------------------------------

		Dim context As CONTEXT
		context.ContextFlags = CONTEXT_CONTROL or CONTEXT_INTEGER
		If GetThreadContext( GetCurrentThread(), context ) = 0 Then
			' TODO: エラー処理
			debug
		End If

		'新しいip, sp, bpをセット
#ifdef _WIN64
		context.Rip = addressOfCatch As QWord
		context.Rbp = tryLayer.basePtr
		context.Rsp = tryLayer.stackPtr
#else
		context.Eip = addressOfCatch As DWord
		context.Ebp = tryLayer.basePtr
		context.Esp = tryLayer.stackPtr
#endif

#ifdef _DEBUG
		Dim ThreadNum As Long
		ThreadNum=_DebugSys_GetThread()
		If ThreadNum <> -1 Then
			_DebugSys_ProcNum[ThreadNum] = tryLayer.debugProcNum-1
		End If
#endif

		If SetThreadContext( GetCurrentThread(), context ) = 0 Then
			OutputDebugString(Ex"レジスタ情報の設定に失敗しました。\r\n")
			Return
		End If
	End Sub

	Sub _ThrowWithParam( ex As Object )
		_Throw( ex )
	End Sub

	Sub _ThrowNoneParam()
		_Throw( Nothing )
	End Sub

	Sub FinishFinally()
		Dim tryLayer = tryLayers[tryLayers.Count - 1]
		tryLayer.FinishFinally()
	End Sub
End Class