'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()
		If Thread.CurrentThread().__IsThrowing() Then
			Throw Thread.CurrentThread().__GetThrowintParamObject()
		End If
	End Sub

	Function ResolveCatchesOverload( ex As Object ) As LONG_PTR
		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 lstrcmp( paramName, ex.GetType().FullName ) = 0 Then
					' マッチしたとき
					Return codePos
				End If
			End If
		Wend
		Return defaultCatchCodePos
	End Function
End Class

Class ExceptionService
	ppTryLayers As **TryLayer
	nTryLayers As Long

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

	Sub ExceptionService()
		ppTryLayers = _System_malloc( 1 )
		nTryLayers = 0
	End Sub
	Sub ~ExceptionService()
		Dim i As Long
		For i = 0 To ELM( nTryLayers )
			Delete ppTryLayers[i]
		Next
		_System_free( ppTryLayers )
		ppTryLayers = 0
	End Sub

	'Try
	Function _BeginTryScope( catchTable As *LONG_PTR, addressOfFinally As VoidPtr, basePtr As LONG_PTR, stackPtr As LONG_PTR ) As TryLayer
		ppTryLayers = _System_realloc( ppTryLayers, ( nTryLayers + 1 ) * SizeOf( *TryLayer ) )
		ppTryLayers[nTryLayers] = New TryLayer( catchTable, addressOfFinally, basePtr, stackPtr )
		nTryLayers++

		Return ByVal ppTryLayers[nTryLayers-1]
	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()
		nTryLayers--
		Delete ppTryLayers[nTryLayers]
	End Sub

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

			'TODO: 適切なエラー処理
			MessageBox( NULL, "例外", "", MB_OK or MB_ICONEXCLAMATION )

			Return
		End If

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

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

		Dim pTryLayer = ppTryLayers[nTryLayers - 1] As *TryLayer

		Dim addressOfCatch = pTryLayer->ResolveCatchesOverload( ex ) As LONG_PTR
		If addressOfCatch Then
			' スレッドへThrow処理が終了した（Catchされた）ことを通知
			Thread.CurrentThread().__Catched()
		Else
			' Catchが定義されていないときはFinallyへ誘導
			addressOfCatch = pTryLayer->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 = pTryLayer->basePtr
		context.Rsp = pTryLayer->stackPtr
#else
		context.Eip = addressOfCatch As DWord
		context.Ebp = pTryLayer->basePtr
		context.Esp = pTryLayer->stackPtr
#endif

#ifdef _DEBUG
		Dim ThreadNum As Long
		ThreadNum=_DebugSys_GetThread()
		If ThreadNum <> -1 Then
			_DebugSys_ProcNum[ThreadNum] = pTryLayer->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 pTryLayer = ppTryLayers[nTryLayers - 1] As *TryLayer
		pTryLayer->FinishFinally()
	End Sub
End Class