bmxparser.bmx

Rem
	Copyright (c) 2010 Noel R. Cower

	This software is provided 'as-is', without any express or implied
	warranty. In no event will the authors be held liable for any damages
	arising from the use of this software.

	Permission is granted to anyone to use this software for any purpose,
	including commercial applications, and to alter it and redistribute it
	freely, subject to the following restrictions:

	1. The origin of this software must not be misrepresented; you must not
	claim that you wrote the original software. If you use this software
	in a product, an acknowledgment in the product documentation would be
	appreciated but is not required.

	2. Altered source versions must be plainly marked as such, and must not be
	misrepresented as being the original software.

	3. This notice may not be removed or altered from any source
	distribution.
EndRem

Strict

Import cower.bmxlexer

Type TNode
	Field owner:TNode
	Field token:TToken
End Type

Type TLiteral
	Field value$
	Field kind:TType
End Type

Type TDecl Extends TNode
	Field metadata:TMap = New TMap	' key<token> => value<token>
	
	Method GetName$(trail:TList) Abstract
End Type

Type TVariable Extends TDecl
	Field name$
	
	Field isGlobal:Int
	Field isConst:Int
	Field type_:TType
	
	Method GetName$(trail:TList)
		Return name
	End Method
	
	Method Decl$(trail:TList)
		Return type_.GetName(trail)+" "+GetName(trail)
	End Method
End Type

Type TType Extends TDecl
	Const TYPE_BYTE:String = "Byte"
	Const TYPE_SHORT:String = "Short"
	Const TYPE_INT:String = "Int"
	Const TYPE_LONG:String = "Long"
	Const TYPE_FLOAT:String = "Float"
	Const TYPE_DOUBLE:String = "Double"
	Const TYPE_STRING:String = "String"
	Const TYPE_OBJECT:String = "Object"
	
	Field kind$
	
	Method ToString$()
		Return kind
	End Method
	
	Function ByteType:TType()
		Local t:TType = New TType
		t.kind = TYPE_BYTE
		Return t
	End Function
	
	Function ShortType:TType()
		Local t:TType = New TType
		t.kind = TYPE_SHORT
		Return t
	End Function
	
	Function IntType:TType()
		Local t:TType = New TType
		t.kind = TYPE_INT
		Return t
	End Function
	
	Function LongType:TType()
		Local t:TType = New TType
		t.kind = TYPE_LONG
		Return t
	End Function
	
	Function FloatType:TType()
		Local t:TType = New TType
		t.kind = TYPE_FLOAT
		Return t
	End Function
	
	Function DoubleType:TType()
		Local t:TType = New TType
		t.kind = TYPE_DOUBLE
		Return t
	End Function
	
	Function StringType:TType()
		Local t:TType = New TType
		t.kind = TYPE_STRING
		Return t
	End Function
	
	Function ObjectType:TType()
		Local t:TType = New TType
		t.kind = TYPE_OBJECT
		Return t
	End Function
	
	Method GetTypeDecl:TTypeDecl(trail:TList)
		For Local block:TBlock = EachIn trail.Reversed()
			For Local typ:TTypeDecl = EachIn block.types
				Local name$ = typ.GetName(trail)
				If name = kind Then
					Return typ
				EndIf
			Next
		Next
		Return Null
	End Method
	
	Method GetName$(trail:TList)
		Select kind
			Case TYPE_OBJECT
				Return "NObject*"
			Case TYPE_FLOAT
				Return "float"
			Case TYPE_INT
				Return "int"
			Case TYPE_LONG
				Return "long long"
			Case TYPE_SHORT
				Return "unsigned short"
			Case TYPE_BYTE
				Return "unsigned char"
			Case TYPE_DOUBLE
				Return "double"
			Case TYPE_STRING
				Return "char*"
		End Select
		
		Local tdecl:TTypeDecl = GetTypeDecl(trail)
		If tdecl Then
			Return tdecl.GetName(trail)
		EndIf
		
		DebugLog "Undefined type '"+kind+"'"
		Return kind
	End Method
End Type

Type TArrayType Extends TType
	Field inner:TType
	Field dims:Int
	Field scales:TList
	
	Method New()
		kind = "Array"
	End Method
	
	Method ToString$()
		Local dimstring$=""
		For Local i:Int = 1 Until dims
			dimstring :+ ","
		Next
		Return inner.ToString()+"["+dimstring+"]"
	End Method
	
	Function Wrap:TArrayType(typ:TType)
		Local a:TArrayType = New TArrayType
		a.inner = typ
		a.dims = 1
		Return a
	End Function
	
	Method GetName$(trail:TList)
		Return inner.GetName(trail)+"*"
	End Method
End Type

Type TPointerType Extends TType
	Field inner:TType
	
	Method ToString$()
		Return inner.ToString()+" Ptr"
	End Method
	
	Method New()
		kind = "Ptr"
	End Method
	
	Function Wrap:TRefType(typ:TType)
		Local r:TRefType = New TRefType
		r.inner = typ
		Return r
	End Function
	
	Method GetName$(trail:TList)
		Return inner.GetName(trail)+"*"
	End Method
End Type

Type TRefType Extends TType
	Field inner:TType
	
	Method ToString$()
		Return inner.ToString()+" Var"
	End Method
	
	Method New()
		kind = "Var"
	End Method
	
	Function Wrap:TRefType(typ:TType)
		Local r:TRefType = New TRefType
		r.inner = typ
		Return r
	End Function
	
	Method GetName$(trail:TList)
		Return inner.GetName(trail)+"&"
	End Method
End Type

Type TBlock Extends TNode
	Field functions:TList = New TList
	Field types:TList = New TList
	Field statements:TList = New TList
End Type

Type TModule Extends TBlock
	Field name$
	Field imports:TList = New TList
End Type

Type TTypeDecl Extends TDecl
	Field name$
	Field types:TList = New TList
	Field methods:TList = New TList
	Field fields:TList = New TList
	Field superclass:TType
	Field isFinal:Int = False
	Field isAbstract:Int = False
	
	Method GetType:TType()
		Local typ:TType = New TType
		typ.kind = name
		Return typ
	End Method
	
	Method GetName$(trail:TList)
		Return name
	End Method
	
	Method Decl$(trail:TList)
		Return name+"Class"
	End Method
End Type

Type TFunction Extends TDecl
	Field name$ = ""
	Field mangledName$ = Null
	Field isStatic:Int = True
	Field isAbstract:Int = False
	Field isFinal:Int = False
	Field isAnon:Int = False
	Field isDebug:Int = True
	Field returnType:TType = Null
	Field callingConv:String = "__cdecl"
	Field parameters:TList = New TList
	Field block:TBlock = New TBlock
	Field owner:TTypeDecl = Null
	
	Method GetName$(trail:TList)
		Return name
	End Method
	
	Method GetMangledName$(trail:TList)
		If mangledName = Null
			Local m$ = name
			If owner Then
				m = owner.GetName(trail)+"_"+name
			EndIf
			mangledName = m
		EndIf
		Return mangledName
	End Method
	
	Method Decl$(trail:TList)
		Local sig$ = ""
		
		If returnType Then
			sig :+ returnType.GetName(trail)
		Else
			sig :+ "void"
		EndIf
		
		sig :+ " " + GetMangledName(trail) + "("
		
		Local iter:TListEnum = parameters.ObjectEnumerator()
		If iter.HasNext() Then
			While iter.HasNext()
				Local param:TVariable = TVariable(iter.NextObject())
				sig :+ param.Decl(trail)
				If iter.HasNext() Then
					sig :+ ", "
				EndIf
			Wend
			sig :+ ")"
		Else
			sig :+ "void)"
		EndIf
		
		Return sig
	End Method
End Type

Type TTokenStream
	Field tokens:TToken[]
	Field _current:Int=0
	
	Method HasNext:Int()
		Return _current < tokens.Length
	End Method
	
	Method Read:TToken(id:Int=-1)
		If Not HasNext() Then
			Return Null
		EndIf
		Local tok:TToken = tokens[_current]
		_current :+ 1
		If tok.kind = TToken.TOK_DOUBLEDOT Then
			Repeat
				tok = tokens[_current]
				_current :+ 1
			Until tok.kind = TToken.TOK_NEWLINE Or Not HasNext()
			tok = tokens[_current]
			_current :+ 1
		EndIf
		Assert id = -1 Or tok.kind = id
		Return tok
	End Method
	
	Method Skip(n:Int=1)
		For Local i:Int = 0 Until n
			Read(-1)
		Next
	End Method
	
	Method Current:TToken()
		If _current = 0 Then Return Null
		Return tokens[_current-1]
	End Method
	
	Method Peek:TToken(id:Int=-1)
		Local mk:Int = Mark()
		Local tok:TToken = Read(-1)
		Reset(mk)
		If id=-1 Or id=tok.kind Then
			Return tok
		Else
			Return Null
		EndIf
	End Method
	
	Method Mark:Int()
		Return _current
	End Method
	
	Method Reset(point:Int)
		_current = point
	End Method
	
	Method PositionString$()
		Return Current().PositionString()
	End Method
End Type

Type TParser
	Field modules:TList = New TList
	Field stack:TList = New TList
	
	Method ParseSource(file$)
		Local lexer:TLexer = New TLexer.InitWithSource(LoadText(file))
		
		Assert lexer.Run() Else lexer.GetError()
		
		Local m:TModule = New TModule
		m.name = file
		stack.AddLast(m)
		
		Local tokens:TToken[] = lexer.GetTokens()
		Local stream:TTokenStream = New TTokenStream
		stream.tokens = tokens
		While stream.HasNext()
			 Local token:TToken = stream.Read()
			
'			DebugLog token.PositionString()+" <"+token.kind+"> "+token.ToString()
			
			Select token.kind
				Case TToken.TOK_TYPE_KW
					ReadTypeDecl(stream)
				
				Case TToken.TOK_ENDTYPE_KW
					EndTypeDecl()
				
				Case TToken.TOK_METHOD_KW
					ReadMethodDecl(stream)
				
				Case TToken.TOK_ENDMETHOD_KW
					EndMethodDecl()
			End Select
		Wend
		
		modules.AddLast(stack.RemoveLast())
		
		New TExporter.Export(modules, "TEST_EXPORT")
	End Method
	
	Method ReadType:TType(stream:TTokenStream)
		Local typ:TType = New TType
		
		Local tok:TToken = stream.Read()
		Select tok.kind
			Case TToken.TOK_ID
				typ.kind = tok.ToString()
			Case TToken.TOK_BYTE_KW, TToken.TOK_AT
				typ.kind = TType.TYPE_BYTE
			Case TToken.TOK_SHORT_KW, TToken.TOK_DOUBLEAT
				typ.kind = TType.TYPE_SHORT
			Case TToken.TOK_INT_KW
				typ.kind = TType.TYPE_INT
			Case TToken.TOK_PERCENT
				Local after:TToken = stream.Peek(TToken.TOK_PERCENT)
				If after And after.DistanceFrom(tok) = 0 Then
					stream.Skip()
					typ.kind = TType.TYPE_LONG
				Else
					typ.kind = TType.TYPE_INT
				EndIf
			Case TToken.TOK_LONG_KW
				typ.kind = TType.TYPE_LONG
			Case TToken.TOK_FLOAT_KW, TToken.TOK_HASH
				typ.kind = TType.TYPE_FLOAT
			Case TToken.TOK_DOUBLE_KW, TToken.TOK_BANG
				typ.kind = TType.TYPE_DOUBLE
			Case TToken.TOK_STRING_KW, TToken.TOK_DOLLAR
				typ.kind = TType.TYPE_STRING
			Case TToken.TOK_OBJECT_KW
				typ.kind = TType.TYPE_OBJECT
			Default
				Throw "No type specified"
		End Select
		
		Local prev:TType
		Repeat
			prev = typ
			tok = stream.Peek()
			
			Select tok.kind
				Case TToken.TOK_OPENBRACKET
					Assert Not TRefType(typ)
					stream.Skip()
					Local bracket:TToken = tok
					Local dims:Int = 1
					
					Local arr:TArrayType = TArrayType.Wrap(typ)
					typ = arr
					
					If Not stream.Peek(TToken.TOK_CLOSEBRACKET) Then
						If stream.Peek(TToken.TOK_COMMA) Then
							Repeat
								tok = stream.Read()
							
								If tok.kind = TToken.TOK_COMMA Then
									dims :+ 1
									Continue
								EndIf
							
								Assert tok.kind = TToken.TOK_CLOSEBRACKET Else bracket.PositionString()+" Mismatched bracket"
								Exit
							Forever
						Else
							Throw "Unsupported"
							Rem
							' TODO: re-add once expression parsing is in
							Local scales:TList = arr.scales
							Repeat
								scales.AddLast(ReadExpression(stream))
								
								tok = stream.Read()
								If tok.kind = TOK_COMMA Then
									dims :+ 1
									Continue
								EndIf
							
								Assert tok.kind = TOK_CLOSEBRACKET Else bracket.PositionString()+" Mismatched bracket"
								Exit
							Forever
							EndRem
						EndIf
					Else
						stream.Skip()
					EndIf
					
					arr.dims = dims
				Case TToken.TOK_PTR_KW
					Assert Not TRefType(typ)
					typ = TPointerType.Wrap(typ)
					stream.Skip()
				Case TToken.TOK_VAR_KW
					Assert Not TRefType(typ)
					typ = TRefType.Wrap(typ)
					stream.Skip()
			End Select
		Until prev = typ
		Return typ
	End Method
	
	Method ReadTypeDecl(stream:TTokenStream)
		Local name:TToken = stream.Read()
		Assert name.kind = TToken.TOK_ID Else "Expected type name, got ~q"+name.ToString()+"~q"
		Local t:TTypeDecl = New TTypeDecl
		t.name = name.ToString()
		DebugLog "Type found: "+t.name
		
		' Check for superclass
		If stream.Peek(TToken.TOK_EXTENDS_KW) Then
			stream.Skip()
			name = stream.Read(TToken.TOK_ID)
			t.superclass = New TType
			t.superclass.kind = name.ToString()
			DebugLog t.name+" extends "+name.ToString()
			' TODO: Default to Object for superclass
		EndIf
		
		' Check for protocol implementations
		If stream.Peek(TToken.TOK_IMPLEMENTS_KW) Then
			Repeat
				stream.Skip()
				name = stream.Read(TToken.TOK_ID)
				DebugLog t.name+" implements protocol "+name.ToString()
			Until Not stream.Peek(TToken.TOK_COMMA)
		EndIf
		
		' Check for abstract/final in either order, including accidental inclusion of both or more than one of either
		Repeat
			If stream.Peek(TToken.TOK_ABSTRACT_KW) Then
				stream.Read()
				Assert Not t.isAbstract Else "Invalid keyword, expected type body, got ~q"+stream.Current().ToString()+"~q"
				Assert Not t.isFinal Else "Abstract types cannot be final"
				t.isAbstract = True
				Continue
			EndIf
		
			If stream.Peek(TToken.TOK_FINAL_KW) Then
				Assert Not t.isFinal Else "Invalid keyword, expected type body, got ~q"+stream.Current().ToString()+"~q"
				Assert Not t.isAbstract Else "Final types cannot be abstract"
				t.isFinal = True
				Continue
			EndIf
			
			Exit
		Forever
		
		stack.AddLast(t)
	End Method
	
	Method EndTypeDecl()
		Local t:TTypeDecl = TTypeDecl(stack.RemoveLast())
		Local par:Object = stack.Last()
		If TBlock(par) Then
			TBlock(par).types.AddLast(t)
		ElseIf TTypeDecl(par) Then
			' inner types
			TTypeDecl(par).types.AddLast(t)
		EndIf
	End Method
	
	Method ReadMethodDecl(stream:TTokenStream)
		Local top:Object = stack.Last()
		
		Assert TTypeDecl(top) Else stream.PositionString()+" Cannot declare methods outside of a type"
		
		Local name:TToken = stream.Read()
		Assert name.kind = TToken.TOK_ID ..
			Or name.kind = TToken.TOK_NEW_KW ..
			Else "Expected method name, got ~q"+name.ToString()+"~q"
		
		Local m:TFunction = New TFunction
		m.isStatic = False
		m.name = name.ToString()
		DebugLog "Method found: "+m.name
		
		Local tok:TToken = stream.Peek()
		
		If tok.kind <> TToken.TOK_OPENPAREN Then
			If tok.kind = TToken.TOK_COLON Then
				stream.Skip()
			EndIf
			m.returnType = ReadType(stream)
		EndIf
		
		ReadParameters(stream, m.parameters)
		
		' Check for abstract/final in either order, including accidental inclusion of both or more than one of either
		Repeat
			If stream.Peek(TToken.TOK_ABSTRACT_KW) Then
				stream.Skip()
				Assert Not m.isAbstract Else "Invalid keyword 'Abstract'"
				Assert Not m.isFinal Else "Abstract methods cannot be final"
				m.isAbstract = True
				Continue
			EndIf
		
			If stream.Peek(TToken.TOK_FINAL_KW) Then
				stream.Skip()
				Assert Not m.isFinal Else "Invalid keyword 'Final'"
				Assert Not m.isAbstract Else "Final methods cannot be abstract"
				m.isFinal = True
				Continue
			EndIf
			
			Exit
		Forever
		
		Local t:TTypeDecl = TTypeDecl(top)
		t.methods.AddLast(m)
		m.owner = t
		
		Local selfVar:TVariable = New TVariable
		selfVar.name="Self"
		selfVar.type_ = t.GetType()
		
		m.parameters.AddFirst(selfVar)
		
		If Not m.isAbstract Then
			stack.AddLast(m)
			stack.AddLast(m.block)
		EndIf
	End Method
	
	Method EndMethodDecl()
		Assert TBlock(stack.RemoveLast()) Else "Mismatched EndMethod"
		Assert TFunction(stack.RemoveLast()) Else "Mismatched EndMethod"
	End Method
	
	Method ReadParameters(stream:TTokenStream, into:TList)
		Function MismatchString$(ps:TList)
			Return TToken(ps.Last()).PositionString()+" Mismatched parentheses"
		End Function
		
		Local depth%=1
		Local tok:TToken = stream.Read(TToken.TOK_OPENPAREN)
		Local parens:TList = New TList
		parens.AddLast(tok)
		Repeat
			If Not stream.HasNext() Then
				Throw MismatchString(parens)
			EndIf
			
			tok = stream.Read()
			'DebugLog "Reading "+tok.PositionString()+" "+tok.ToString()
			Assert tok.kind <> TToken.TOK_NEWLINE Else MismatchString(parens)
			
			If tok.kind = TToken.TOK_OPENPAREN Then
				parens.AddLast(tok)
				depth :+ 1
			ElseIf tok.kind = TToken.TOK_CLOSEPAREN Then
				parens.RemoveLast()
				depth :- 1
			EndIf
		Until depth = 0 And tok.kind = TToken.TOK_CLOSEPAREN
	End Method
	
	Method ReadMetadata(stream:TTokenStream)
		Local decl:TDecl = TDecl(stack.Last())
		Assert decl Else "Can only apply metadata to declarations"
		Repeat
			Local name:TToken = stream.Read(TToken.TOK_ID)
			stream.Read(TToken.TOK_EQUALS)
			Local value:TToken = stream.Read()
			Assert value.kind = TToken.TOK_STRING_LIT ..
				Or value.kind = TToken.TOK_NUMBER_LIT ..
				Or value.kind = TToken.TOK_HEX_LIT ..
				Or value.kind = TToken.TOK_BIN_LIT ..
				Else "Can only assign string or number literals to metadata"
			
			' NOTE: Apparently you can have duplicates in metadata
'			Assert Not decl.metadata.Contains(name) Else ..
'				"Duplicate metadata for name '"+name.ToString()+"'"
			
			decl.metadata.Insert(name, value)
			
			DebugLog "Metadata found ~q"+name.ToString()+"~q=>~q"+value.ToString()+"~q"
			
			If Not stream.HasNext() Then
				Throw "End of token stream before metadata ended"
			EndIf
		Until stream.Peek(TToken.TOK_CLOSECURL)
		
	End Method
End Type

' Crappy little C exporter because I was bored
Type TExporter
	Method Export(modules:TList, toFile$)
		Local header:TStream = WriteFile(toFile+".hpp")
		Local trail:TList = New TList
		
		For Local m:TModule = EachIn modules
			trail.AddLast(m)
			
			For Local t:TTypeDecl = EachIn m.types
				ExportTypeDecl t, trail, header
			Next
			
			header.WriteLine("")
			
'			For Local t:TTypeDecl = EachIn m.types
'				ExportTypeClass t, trail, header
'			Next
			
			Assert trail.RemoveLast()=m Else "Trail not cleaned up properly"
		Next
		
		header.Close()
	End Method
	
	Method ExportTypeDecl(typ:TTypeDecl, trail:TList, stream:TStream)
		Local ctor:TFunction
		Local dtor:TFunction
		Local meths:Int = 0
		Local superdecl:TTypeDecl = Null
		If typ.superclass Then superdecl = typ.superclass.GetTypeDecl(trail)
		
		stream.WriteLine("typedef object_t* "+typ.GetName(trail)+";")
		stream.WriteLine("")
		
		Local iter:TListEnum = typ.methods.ObjectEnumerator()
		If iter.HasNext() Then
			While iter.HasNext()
				Local fn:TFunction = TFunction(iter.NextObject())
				stream.WriteLine(fn.Decl(trail)+";")
				
				If fn.GetName(trail).ToLower()="new" Then
					ctor = fn
					Continue
				ElseIf fn.GetName(trail).ToLower()="delete" Then
					dtor = fn
					Continue
				EndIf
				meths :+ 1
			Wend
			stream.WriteLine("")
		EndIf
		stream.WriteLine("class_t "+typ.Decl(trail)+" = {")
		If superdecl Then
			stream.WriteLine("~t&"+superdecl.Decl(trail)+",")
		Else
			stream.WriteLine("~tNULL,")
		EndIf
		stream.WriteLine("~t~q"+typ.GetName(trail)+"~q,")	' name
		stream.WriteLine("~t0,") ' instance size
		If Not (ctor Or dtor) Then
			stream.WriteLine("~tNULL, NULL,") ' ctor/dtor
		Else
			If ctor Then
				stream.WriteLine("~t"+ctor.GetMangledName(trail)+",")
			Else
				stream.WriteLine("~tNULL,")
			EndIf
			If dtor Then
				stream.WriteLine("~t"+dtor.GetMangledName(trail)+",")
			Else
				stream.WriteLine("~tNULL,")
			EndIf
		EndIf
		stream.WriteLine("~t"+meths+",") 'method count
		stream.WriteLine("~tNULL,")
		stream.WriteLine("~t0,")
		stream.WriteLine("~tNULL")
		stream.WriteLine("}; // "+typ.Decl(trail))
		stream.WriteLine("")
		stream.WriteLine("void __"+typ.Decl(trail)+"_init() {")
		iter = typ.methods.ObjectEnumerator()
		If iter.HasNext() Then
			stream.WriteLine("~tmethod_info_t* methods = (method_info_t*)malloc(sizeof(method_info_t)*"+typ.Decl(trail)+".num_methods);")
			Local methIdx:Int = 0
			While iter.HasNext()
				Local fn:TFunction = TFunction(iter.NextObject())
				If fn = ctor Or fn = dtor Then
					Continue
				EndIf
				stream.WriteLine("~tmethods["+methIdx+"].name = ~q"+fn.GetName(trail)+"~q;")
				stream.WriteLine("~tmethods["+methIdx+"].signature = ~q~q;")
				stream.WriteLine("~tmethods["+methIdx+"].method = (method_t)"+fn.GetMangledName(trail)+";")
				methIdx :+ 1
			Wend
		EndIf
		If superdecl Then
			stream.WriteLine("~t__"+superdecl.Decl(trail)+"_init();")
		EndIf
		stream.WriteLine("}")
		stream.WriteLine("")
	End Method
	
	Method ExportTypeClass(typ:TTypeDecl, trail:TList, stream:TStream)
		Local name$ = typ.GetName(trail)
		stream.WriteString("class "+name)
		If typ.superclass Then
			stream.WriteString(" : public "+typ.superclass.kind)
		EndIf
		stream.WriteString(" {~n")
		stream.WriteLine("public:")
		For Local fn:TFunction = EachIn typ.methods
			stream.WriteLine("~t"+fn.Decl(trail)+";")
		Next
		stream.WriteLine("};")
	End Method
End Type