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

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

Class TryLayer
Public
    Const addressOfCatch As VoidPtr
    Const basePtr As LONG_PTR
    Const stackPtr As LONG_PTR
    Const debugProcNum As DWord
    
    Sub TryLayer( addressOfCatch As VoidPtr, basePtr As LONG_PTR, stackPtr As LONG_PTR )
        This.addressOfCatch = addressOfCatch
        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
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( addressOfCatch As VoidPtr, basePtr As LONG_PTR, stackPtr As LONG_PTR ) As TryLayer
        ppTryLayers = _System_realloc( ppTryLayers, ( nTryLayers + 1 ) * SizeOf( *TryLayer ) )
        ppTryLayers[nTryLayers] = New TryLayer( addressOfCatch, basePtr, stackPtr )
        nTryLayers++

        Return ByVal ppTryLayers[nTryLayers-1]
    End Function

    Static Function BeginTryScope( addressOfCatch As VoidPtr, basePtr As LONG_PTR, stackPtr As LONG_PTR ) As TryLayer
        Return _System_pobj_AllThreads->GetCurrentException()->_BeginTryScope( addressOfCatch, basePtr, stackPtr )
    End Function

    'End Try
    Sub EndTryScope()
        nTryLayers--
        Delete ppTryLayers[nTryLayers]
    End Sub

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

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

            Return
        End If

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



        '--------------------------------------------------
        ' スレッドのコンテキストを設定（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 = ppTryLayers[nTryLayers - 1]->addressOfCatch As QWord
        context.Rbp = ppTryLayers[nTryLayers - 1]->basePtr
        context.Rsp = ppTryLayers[nTryLayers - 1]->stackPtr
#else
        context.Eip = ppTryLayers[nTryLayers - 1]->addressOfCatch As DWord
        context.Ebp = ppTryLayers[nTryLayers - 1]->basePtr
        context.Esp = ppTryLayers[nTryLayers - 1]->stackPtr
#endif

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

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

    Sub _Throw( msg As String )
        _Throw()
    End Sub
End Class