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

		Search = types.Item(fullName)

		If Object.ReferenceEquals( Search, Nothing ) Then
			OutputDebugString("TypeSearch Failed: ")
			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")
		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