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

'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 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

    Function isCatchable(paramName As String, catchType As System.TypeInfo) As Boolean
        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
    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, "Catchされていない例外があります", NULL, MB_OK or MB_ICONEXCLAMATION )
            Debug
            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 = NULL Then
            ' 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