source: trunk/ab5.0/ablib/src/Classes/ActiveBasic/Core/TypeInfo.ab@ 655

Namespace ActiveBasic
Namespace Core


' 中間的な実装（継承専用）
Class TypeBaseImpl
    Inherits System.TypeInfo

    strNamespace As String
    name As String
    fullName As String

    ptrType As TypeBaseImpl
    ptrLevel As Long

    ' メンバ情報
    memberNames As *String              ' 名前リスト
    memberTypeFullNames As *String      ' 型名リスト
    memberOffsets As *LONG_PTR          ' クラスの先頭ポインタからのオフセット値
    memberCounts As Long                ' 個数
    memberInfosCache As System.Collections.Generic.List<System.Reflection.MemberInfo>

Protected

    baseType As System.TypeInfo
    'interfaces As f(^^;;;

    Sub TypeBaseImpl( strNamespace As String, name As String, fullName As String )
        This.strNamespace = strNamespace
        This.name = name
        This.fullName = fullName
        This.baseType = Nothing

        ptrType = Nothing
        ptrLevel = 0
    End Sub

    Sub ~TypeBaseImpl()
    End Sub

    Sub PtrLevelUp()
        ptrLevel ++
        fullName = "*" + fullName
    End Sub

    Function Clone() As TypeBaseImpl
        Dim result = New TypeBaseImpl( strNamespace, name, fullName )
        result.SetBaseType( baseType )
        result.SetMembers( memberNames, memberTypeFullNames, memberOffsets, memberCounts )
        result.memberInfosCache = This.memberInfosCache
        result.ptrLevel = This.ptrLevel
        Return result
    End Function

Public

    Sub SetMembers( memberNames As *String, memberTypeFullNames As *String, memberOffsets As *LONG_PTR, num As Long )
        This.memberNames = memberNames
        This.memberTypeFullNames = memberTypeFullNames
        This.memberOffsets = memberOffsets
        This.memberCounts = num

        /*
        OutputDebugString( Ex"\r\n" )
        Dim i As Long
        For i=0 To ELM(num)
            OutputDebugString( memberNames[i] )
            OutputDebugString( ", " )
            OutputDebugString( memberTypeFullNames[i] )
            OutputDebugString( Ex"\r\n" )
        Next
        */
    End Sub

    Sub SetBaseType( baseType As System.TypeInfo )
        This.baseType = baseType
    End Sub

    Function GetPtrType() As TypeBaseImpl
        If Object.ReferenceEquals( ptrType, Nothing ) Then
            Dim clone = This.Clone()

            ptrType = clone
            ptrType.PtrLevelUp()
        End If
        Return ptrType
    End Function


    '----------------------------------------------------------------
    ' Public properties
    '----------------------------------------------------------------

    Override Function BaseType() As System.TypeInfo
        Return baseType
    End Function

    Override Function FullName() As String
        Return fullName
    End Function

    Override Function IsArray() As Boolean
        Return False
    End Function

    Override Function IsByRef() As Boolean
        Return False
    End Function

    Override Function IsClass() As Boolean
        Return False
    End Function

    Override Function IsEnum() As Boolean
        Return False
    End Function

    Override Function IsInterface() As Boolean
        Return False
    End Function

    Override Function IsPointer() As Boolean
        Return ( ptrLevel > 0 )
    End Function

    Override Function IsValueType() As Boolean
        Return False
    End Function

    Override Function Name() As String
        Return name
    End Function

    Override Function Namespace() As String
        Return strNamespace
    End Function



    '----------------------------------------------------------------
    ' Public methods
    '----------------------------------------------------------------

    Override Function GetMembers() As System.Collections.Generic.List<System.Reflection.MemberInfo>
        If Object.ReferenceEquals( memberInfosCache, Nothing ) Then
            ' キャッシュにないときは生成する
            memberInfosCache = New System.Collections.Generic.List
            Dim i As Long
            For i=0 To ELM(memberCounts)
                memberInfosCache.Add( New System.Reflection.MemberInfo( memberNames[i], _System_TypeBase_Search( memberTypeFullNames[i] ), memberOffsets[i] ) )
            Next
        End If

        Return memberInfosCache
    End Function

End Class


' 値型を管理するためのクラス
Class _System_TypeForValueType
    Inherits TypeBaseImpl
Public
    Sub _System_TypeForValueType( name As String )
        TypeBaseImpl( "", name, name )
    End Sub

    Override Function IsValueType() As Boolean
        Return True
    End Function
End Class

TypeDef _SYSTEM_CONSTRUCTOR_PROC = *Sub( pThis As *Object )
TypeDef _SYSTEM_DESTRUCTOR_PROC = *Sub( pThis As *Object )

' クラスを管理するためのクラス
Class _System_TypeForClass
    Inherits TypeBaseImpl

    Static Const _SYSTEM_OBJECT_HEAD_SIZE = SizeOf(LONG_PTR) * 4

    size As SIZE_T
    comVtbl As VoidPtr
    vtblList As VoidPtr
    pDefaultConstructor As _SYSTEM_CONSTRUCTOR_PROC
    pDestructor As _SYSTEM_DESTRUCTOR_PROC

Public
    referenceOffsets As *Long
    numOfReference As Long

    Sub _System_TypeForClass( strNamespace As String, name As String, fullName As String, referenceOffsets As *Long, numOfReference As Long )
        TypeBaseImpl( strNamespace, name, fullName )

        This.referenceOffsets = referenceOffsets
        This.numOfReference = numOfReference
    End Sub
    Sub _System_TypeForClass( strNamespace As String, name As String, fullName As String )
        TypeBaseImpl( strNamespace, name, fullName )
    End Sub
    Sub ~_System_TypeForClass()
    End Sub

    Sub SetClassInfo( size As SIZE_T, comVtbl As VoidPtr, vtblList As VoidPtr, pDefaultConstructor As _SYSTEM_CONSTRUCTOR_PROC, pDestructor As _SYSTEM_DESTRUCTOR_PROC )
        This.size = size
        This.comVtbl = comVtbl
        This.vtblList = vtblList
        This.pDefaultConstructor = pDefaultConstructor
        This.pDestructor = pDestructor
    End Sub

    Override Function IsClass() As Boolean
        Return True
    End Function


    Static Function _System_New( typeForClass As ActiveBasic.Core._System_TypeForClass ) As Object
        If typeForClass.pDefaultConstructor = NULL Then
            Throw New System.SystemException( "デフォルトコンストラクタを持たないクラスに対して_System_New関数は使えません。" )
        End If

        ' まずはメモリを確保
        Dim pPtr = _System_GC_malloc_ForObject( typeForClass.size + _SYSTEM_OBJECT_HEAD_SIZE ) As VoidPtr

        ' pPtr[0]=オブジェクトの個数
        Set_LONG_PTR( pPtr, 1 )
        pPtr += SizeOf(LONG_PTR)

        ' pPtr[1]=オブジェクトのサイズ
        Set_LONG_PTR( pPtr, typeForClass.size )
        pPtr += SizeOf(LONG_PTR)

        ' pPtr[2]=デストラクタの関数ポインタ
        Set_LONG_PTR( pPtr, typeForClass.pDestructor As LONG_PTR )
        pPtr += SizeOf(LONG_PTR)

        ' pPtr[3]=reserve
        pPtr += SizeOf(LONG_PTR)

        Dim pObject = pPtr As *Object

        ' com_vtblをセット
        Set_LONG_PTR( pObject, typeForClass.comVtbl As LONG_PTR )

        ' vtbl_listをセット
        Set_LONG_PTR( pObject + SizeOf(LONG_PTR), typeForClass.vtblList As LONG_PTR )

        ' 動的型情報をセットする
        pObject->_System_SetType( typeForClass )

        ' コンストラクタを呼び出す
        Dim proc = typeForClass.pDefaultConstructor
        proc( pObject )

        Return ByVal pObject
    End Function
End Class

' インターフェイスを管理するためのクラス
Class _System_TypeForInterface
    Inherits TypeBaseImpl
Public
End Class

' 列挙体を管理するためのクラス
Class _System_TypeForEnum
    Inherits TypeBaseImpl
Public
End Class

' デリゲートを管理するためのクラス
Class _System_TypeForDelegate
    Inherits TypeBaseImpl
Public
End Class


'--------------------------------------------------------------------
' プロセスに存在するすべての型を管理する
'--------------------------------------------------------------------
Class _System_TypeBase
    Static types As System.Collections.Generic.Dictionary<String, TypeBaseImpl>

    Static isReady = False

    Static Sub Add( typeInfo As TypeBaseImpl )
        types.Add( typeInfo.FullName, typeInfo )
    End Sub

    Static Sub InitializeValueType()
        types = New System.Collections.Generic.Dictionary<String, TypeBaseImpl>(8191)

        ' 値型の追加
        Add( _System_Static_New _System_TypeForValueType[ strNamespace = "", name = "Byte", fullName = "Byte" ] )
        Add( _System_Static_New _System_TypeForValueType[ strNamespace = "", name = "SByte", fullName = "SByte" ] )
        Add( _System_Static_New _System_TypeForValueType[ strNamespace = "", name = "Word", fullName = "Word" ] )
        Add( _System_Static_New _System_TypeForValueType[ strNamespace = "", name = "Integer", fullName = "Integer" ] )
        Add( _System_Static_New _System_TypeForValueType[ strNamespace = "", name = "DWord", fullName = "DWord" ] )
        Add( _System_Static_New _System_TypeForValueType[ strNamespace = "", name = "Long", fullName = "Long" ] )
        Add( _System_Static_New _System_TypeForValueType[ strNamespace = "", name = "QWord", fullName = "QWord" ] )
        Add( _System_Static_New _System_TypeForValueType[ strNamespace = "", name = "Int64", fullName = "Int64" ] )
        Add( _System_Static_New _System_TypeForValueType[ strNamespace = "", name = "Boolean", fullName = "Boolean" ] )
        Add( _System_Static_New _System_TypeForValueType[ strNamespace = "", name = "Single", fullName = "Single" ] )
        Add( _System_Static_New _System_TypeForValueType[ strNamespace = "", name = "Double", fullName = "Double" ] )
        Add( _System_Static_New _System_TypeForValueType[ strNamespace = "", name = "VoidPtr", fullName = "VoidPtr" ] )
    End Sub

    Static Sub InitializeUserTypes()
        ' このメソッドの実装はコンパイラが自動生成する

        '例:
        'Add( New _System_TypeForClass( "System", "String", "System.String", [__offsets...], __numOfOffsets ) )
        '...
    End Sub
    Static Sub InitializeUserTypesForBaseType()
        ' このメソッドの実装はコンパイラが自動生成する

        '例:
        'Search( "System.String" ).SetBaseType( Search( "System.Object" ) )
        '...
    End Sub

Public
    Static Sub Initialize()
        ' 値型を初期化
        InitializeValueType()

        ' Class / Interface / Enum / Delegate を初期化
        InitializeUserTypes()

        isReady = True

        ' 基底クラスを登録
        InitializeUserTypesForBaseType()

        selfTypeInfo = _System_TypeBase.Search( "System.TypeInfo" ) As System.TypeInfo

        _System_DebugOnly_OutputDebugString( Ex"ready dynamic meta datas!\r\n" )
    End Sub

    Static Sub _NextPointerForGC()
        ' TODO: 実装
    End Sub

    Static Function Search( fullName As String ) As TypeBaseImpl
        If Object.ReferenceEquals(types, Nothing) Then
            Return Nothing
        End If

        If isReady = False Then
            Return Nothing
        End If

        If fullName[0] = &H2A Then      ' fullName[0] = '*'
            Dim result = Search( fullName.Substring( 1 ) )
            Return result.GetPtrType()
        End If

        If Not types.TryGetValue(fullName, Search) Then
            OutputDebugString(Ex"TypeSearch Failed: \r\n")
            If Not ActiveBasic.IsNothing(fullName) Then
                OutputDebugStringW(StrPtr(fullName) As PWSTR)
                OutputDebugString(Ex"\r\n")
                OutputDebugStringA(StrPtr(fullName) As PSTR)
            End If
            OutputDebugString(Ex"\r\n")
            Debug
        End If
    End Function

    Static Function IsReady() As Boolean
        Return isReady
    End Function

    Static selfTypeInfo As System.TypeInfo

End Class


End Namespace
End Namespace

Function _System_TypeBase_Search( fullName As String ) As ActiveBasic.Core.TypeBaseImpl
    Return ActiveBasic.Core._System_TypeBase.Search( fullName )
End Function