Compare commits
46 Commits
88604bf544
...
7cbf8aad08
Author | SHA1 | Date | |
---|---|---|---|
|
7cbf8aad08 | ||
|
93702071fb | ||
7bfdeed620 | |||
|
176b98d659 | ||
ced5d1df9c | |||
acab0add95 | |||
|
c0d48b5274 | ||
b040130569 | |||
e723e9cb18 | |||
d47c7f5a45 | |||
8c3c3625b9 | |||
f9df24f456 | |||
b7d8f19433 | |||
|
8b5650dd61 | ||
068b97e0e7 | |||
c920a3dfb6 | |||
358293d4d4 | |||
7422510267 | |||
40c7cab0e3 | |||
|
f988c80b83 | ||
|
ff03be2671 | ||
|
c248dc3676 | ||
75272498c4 | |||
8d9d28cb1f | |||
f14470d8cc | |||
ae6232380e | |||
0debfe995d | |||
62bd191314 | |||
af7162ea54 | |||
dbdd2f85bd | |||
|
f93a1ba58c | ||
|
967c3a4b41 | ||
|
e2f978ca93 | ||
f4c70d4d30 | |||
|
580e56ebbb | ||
fa9cb761d5 | |||
fa2dc24aa0 | |||
fe4091da99 | |||
db2b4a142c | |||
95063ac64f | |||
4108eb58c1 | |||
ecd778cc70 | |||
e5baa701b2 | |||
5d49da69a6 | |||
b8e566a2a0 | |||
6d39110794 |
6
.gitignore
vendored
6
.gitignore
vendored
@ -8,6 +8,12 @@ cabal-dev
|
|||||||
*.chs.h
|
*.chs.h
|
||||||
*.dyn_o
|
*.dyn_o
|
||||||
*.dyn_hi
|
*.dyn_hi
|
||||||
|
*.java
|
||||||
|
*.class
|
||||||
|
*.local~*
|
||||||
|
src/Parser/JavaParser.hs
|
||||||
|
src/Parser/Parser.hs
|
||||||
|
src/Parser/Lexer.hs
|
||||||
.hpc
|
.hpc
|
||||||
.hsenv
|
.hsenv
|
||||||
.cabal-sandbox/
|
.cabal-sandbox/
|
||||||
|
116
Test/TestByteCodeGenerator.hs
Normal file
116
Test/TestByteCodeGenerator.hs
Normal file
@ -0,0 +1,116 @@
|
|||||||
|
module TestByteCodeGenerator where
|
||||||
|
|
||||||
|
import Test.HUnit
|
||||||
|
import ByteCode.ClassFile.Generator
|
||||||
|
import ByteCode.ClassFile
|
||||||
|
import ByteCode.Constants
|
||||||
|
import Ast
|
||||||
|
|
||||||
|
nakedClass = Class "Testklasse" [] []
|
||||||
|
expectedClass = ClassFile {
|
||||||
|
constantPool = [
|
||||||
|
ClassInfo 4,
|
||||||
|
MethodRefInfo 1 3,
|
||||||
|
NameAndTypeInfo 5 6,
|
||||||
|
Utf8Info "java/lang/Object",
|
||||||
|
Utf8Info "<init>",
|
||||||
|
Utf8Info "()V",
|
||||||
|
Utf8Info "Code",
|
||||||
|
ClassInfo 9,
|
||||||
|
Utf8Info "Testklasse"
|
||||||
|
],
|
||||||
|
accessFlags = accessPublic,
|
||||||
|
thisClass = 8,
|
||||||
|
superClass = 1,
|
||||||
|
fields = [],
|
||||||
|
methods = [],
|
||||||
|
attributes = []
|
||||||
|
}
|
||||||
|
|
||||||
|
classWithFields = Class "Testklasse" [] [VariableDeclaration "int" "testvariable" Nothing]
|
||||||
|
expectedClassWithFields = ClassFile {
|
||||||
|
constantPool = [
|
||||||
|
ClassInfo 4,
|
||||||
|
MethodRefInfo 1 3,
|
||||||
|
NameAndTypeInfo 5 6,
|
||||||
|
Utf8Info "java/lang/Object",
|
||||||
|
Utf8Info "<init>",
|
||||||
|
Utf8Info "()V",
|
||||||
|
Utf8Info "Code",
|
||||||
|
ClassInfo 9,
|
||||||
|
Utf8Info "Testklasse",
|
||||||
|
FieldRefInfo 8 11,
|
||||||
|
NameAndTypeInfo 12 13,
|
||||||
|
Utf8Info "testvariable",
|
||||||
|
Utf8Info "I"
|
||||||
|
],
|
||||||
|
accessFlags = accessPublic,
|
||||||
|
thisClass = 8,
|
||||||
|
superClass = 1,
|
||||||
|
fields = [
|
||||||
|
MemberInfo {
|
||||||
|
memberAccessFlags = accessPublic,
|
||||||
|
memberNameIndex = 12,
|
||||||
|
memberDescriptorIndex = 13,
|
||||||
|
memberAttributes = []
|
||||||
|
}
|
||||||
|
],
|
||||||
|
methods = [],
|
||||||
|
attributes = []
|
||||||
|
}
|
||||||
|
|
||||||
|
method = MethodDeclaration "int" "add_two_numbers" [
|
||||||
|
ParameterDeclaration "int" "a",
|
||||||
|
ParameterDeclaration "int" "b" ]
|
||||||
|
(Block [Return (Just (BinaryOperation Addition (Reference "a") (Reference "b")))])
|
||||||
|
|
||||||
|
|
||||||
|
classWithMethod = Class "Testklasse" [method] []
|
||||||
|
expectedClassWithMethod = ClassFile {
|
||||||
|
constantPool = [
|
||||||
|
ClassInfo 4,
|
||||||
|
MethodRefInfo 1 3,
|
||||||
|
NameAndTypeInfo 5 6,
|
||||||
|
Utf8Info "java/lang/Object",
|
||||||
|
Utf8Info "<init>",
|
||||||
|
Utf8Info "()V",
|
||||||
|
Utf8Info "Code",
|
||||||
|
ClassInfo 9,
|
||||||
|
Utf8Info "Testklasse",
|
||||||
|
FieldRefInfo 8 11,
|
||||||
|
NameAndTypeInfo 12 13,
|
||||||
|
Utf8Info "add_two_numbers",
|
||||||
|
Utf8Info "(II)I"
|
||||||
|
],
|
||||||
|
accessFlags = accessPublic,
|
||||||
|
thisClass = 8,
|
||||||
|
superClass = 1,
|
||||||
|
fields = [],
|
||||||
|
methods = [
|
||||||
|
MemberInfo {
|
||||||
|
memberAccessFlags = accessPublic,
|
||||||
|
memberNameIndex = 12,
|
||||||
|
memberDescriptorIndex = 13,
|
||||||
|
memberAttributes = [
|
||||||
|
CodeAttribute {
|
||||||
|
attributeMaxStack = 420,
|
||||||
|
attributeMaxLocals = 420,
|
||||||
|
attributeCode = [Opiadd]
|
||||||
|
}
|
||||||
|
]
|
||||||
|
}
|
||||||
|
],
|
||||||
|
attributes = []
|
||||||
|
}
|
||||||
|
|
||||||
|
testBasicConstantPool = TestCase $ assertEqual "basic constant pool" expectedClass $ classBuilder nakedClass emptyClassFile
|
||||||
|
testFields = TestCase $ assertEqual "fields in constant pool" expectedClassWithFields $ classBuilder classWithFields emptyClassFile
|
||||||
|
testMethodDescriptor = TestCase $ assertEqual "method descriptor" "(II)I" (methodDescriptor method)
|
||||||
|
testMethodAssembly = TestCase $ assertEqual "method assembly" expectedClassWithMethod (classBuilder classWithMethod emptyClassFile)
|
||||||
|
|
||||||
|
tests = TestList [
|
||||||
|
TestLabel "Basic constant pool" testBasicConstantPool,
|
||||||
|
TestLabel "Fields constant pool" testFields,
|
||||||
|
TestLabel "Method descriptor building" testMethodDescriptor,
|
||||||
|
TestLabel "Method assembly" testMethodAssembly
|
||||||
|
]
|
@ -4,14 +4,46 @@ import Test.HUnit
|
|||||||
import Parser.Lexer
|
import Parser.Lexer
|
||||||
|
|
||||||
|
|
||||||
testCommentSomething = TestCase $ assertEqual "scan /*Something*/" [Comment "/*Something*/"] $ alexScanTokens "/*Something*/"
|
emptyTokenList :: [Token]
|
||||||
testEmptyComment = TestCase $ assertEqual "scan /*x*/" [Comment "/**/"] $ alexScanTokens "/**/"
|
emptyTokenList = []
|
||||||
testLineComment = TestCase $ assertEqual "scan // comment" [Comment "// comment"] $ alexScanTokens "// comment"
|
testCommentSomething = TestCase $ assertEqual "scan '/*Something*/'" emptyTokenList $ alexScanTokens "/*Something*/"
|
||||||
|
testEmptyComment = TestCase $ assertEqual "scan '/*x*/'" emptyTokenList $ alexScanTokens "/**/"
|
||||||
|
testLineComment = TestCase $ assertEqual "scan '// comment'" emptyTokenList $ alexScanTokens "// comment"
|
||||||
|
testLineCommentEnds = TestCase $ assertEqual "scan '// com\\n'" emptyTokenList $ alexScanTokens "// com\n"
|
||||||
|
|
||||||
|
testIdentifier = TestCase $ assertEqual "scan 'identifier'" [IDENTIFIER "identifier"] $ alexScanTokens "identifier"
|
||||||
|
testShortIdentifier = TestCase $ assertEqual "scan 'i'" [IDENTIFIER "i"] $ alexScanTokens "i"
|
||||||
|
testIdentifierWithNumber = TestCase $ assertEqual "scan 'i2'" [IDENTIFIER "i2"] $ alexScanTokens "i2"
|
||||||
|
|
||||||
|
testKeywordBreak = TestCase $ assertEqual "scan 'break'" [BREAK] $ alexScanTokens "break"
|
||||||
|
testKeywordInt = TestCase $ assertEqual "scan 'int'" [INT] $ alexScanTokens "int"
|
||||||
|
|
||||||
|
testIntLiteral = TestCase $ assertEqual "scan '234'" [INTEGERLITERAL 234] $ alexScanTokens "234"
|
||||||
|
testIntLiteral2 = TestCase $ assertEqual "scan '54_2'" [INTEGERLITERAL 542] $ alexScanTokens "54_2"
|
||||||
|
|
||||||
|
testCharLiteral = TestCase $ assertEqual "scan ''f''" [CHARLITERAL 'f'] $ alexScanTokens "'f'"
|
||||||
|
|
||||||
|
testBoolLiteralTrue = TestCase $ assertEqual "scan 'true'" [BOOLLITERAL True] $ alexScanTokens "true"
|
||||||
|
testBoolLiteralFalse = TestCase $ assertEqual "scan 'false'" [BOOLLITERAL False] $ alexScanTokens "false"
|
||||||
|
|
||||||
|
testLBrace = TestCase $ assertEqual "scan '('" [LBRACE] $ alexScanTokens "("
|
||||||
|
testAnd = TestCase $ assertEqual "scan '&&'" [AND] $ alexScanTokens "&&"
|
||||||
|
|
||||||
tests = TestList [
|
tests = TestList [
|
||||||
TestLabel "TestCommentSomething" testCommentSomething,
|
TestLabel "TestCommentSomething" testCommentSomething,
|
||||||
TestLabel "TestEmptyComment" testEmptyComment,
|
TestLabel "TestEmptyComment" testEmptyComment,
|
||||||
TestLabel "TestLineComment" testLineComment
|
TestLabel "TestLineComment" testLineComment,
|
||||||
|
TestLabel "TestLineCommentEnds" testLineCommentEnds,
|
||||||
|
TestLabel "TestIdentifier" testIdentifier,
|
||||||
|
TestLabel "TestShortIdentifier" testShortIdentifier,
|
||||||
|
TestLabel "TestIdentifierWithNumber" testIdentifierWithNumber,
|
||||||
|
TestLabel "TestKeywordBreak" testKeywordBreak,
|
||||||
|
TestLabel "TestKeywordInt" testKeywordInt,
|
||||||
|
TestLabel "TestIntLiteral" testIntLiteral,
|
||||||
|
TestLabel "TestIntLiteral2" testIntLiteral2,
|
||||||
|
TestLabel "TestCharLiteral" testCharLiteral,
|
||||||
|
TestLabel "TestBoolLiteralTrue" testBoolLiteralTrue,
|
||||||
|
TestLabel "TestBoolLiteralFalse" testBoolLiteralFalse,
|
||||||
|
TestLabel "TestLBrace" testLBrace,
|
||||||
|
TestLabel "TestAnd" testAnd
|
||||||
]
|
]
|
28
Test/TestParser.hs
Normal file
28
Test/TestParser.hs
Normal file
@ -0,0 +1,28 @@
|
|||||||
|
module TestParser(tests) where
|
||||||
|
|
||||||
|
import Test.HUnit
|
||||||
|
import Parser.Lexer
|
||||||
|
import Parser.JavaParser
|
||||||
|
import Ast
|
||||||
|
|
||||||
|
|
||||||
|
testSingleEmptyClass = TestCase $
|
||||||
|
assertEqual "expect single empty class hello" [Class "Hello" [] []] $
|
||||||
|
parse [CLASS, IDENTIFIER "Hello", LBRACKET, RBRACKET]
|
||||||
|
testTwoEmptyClasses = TestCase $
|
||||||
|
assertEqual "expect two empty classes" [Class "Class1" [] [], Class "Class2" [] []] $
|
||||||
|
parse [CLASS,IDENTIFIER "Class1",LBRACKET,RBRACKET,CLASS,IDENTIFIER "Class2",LBRACKET,RBRACKET]
|
||||||
|
testBooleanField = TestCase $
|
||||||
|
assertEqual "expect class with boolean field" [Class "WithBool" [] [VariableDeclaration "boolean" "value" Nothing]] $
|
||||||
|
parse [CLASS,IDENTIFIER "WithBool",LBRACKET,BOOLEAN,IDENTIFIER "value",SEMICOLON,RBRACKET]
|
||||||
|
testIntField = TestCase $
|
||||||
|
assertEqual "expect class with int field" [Class "WithInt" [] [VariableDeclaration "int" "value" Nothing]] $
|
||||||
|
parse [CLASS,IDENTIFIER "WithInt",LBRACKET,INT,IDENTIFIER "value",SEMICOLON,RBRACKET]
|
||||||
|
|
||||||
|
|
||||||
|
tests = TestList [
|
||||||
|
testSingleEmptyClass,
|
||||||
|
testTwoEmptyClasses,
|
||||||
|
testBooleanField,
|
||||||
|
testIntField
|
||||||
|
]
|
@ -1,11 +1,14 @@
|
|||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Test.HUnit
|
import Test.HUnit
|
||||||
import Parser.Lexer
|
|
||||||
import TestLexer
|
import TestLexer
|
||||||
|
import TestByteCodeGenerator
|
||||||
|
import TestParser
|
||||||
|
|
||||||
otherTest = TestCase $ assertEqual "math" (4+3) 7
|
|
||||||
|
|
||||||
tests = TestList [TestLabel "TestLexer" TestLexer.tests, TestLabel "mathTest" otherTest]
|
tests = TestList [
|
||||||
|
TestLabel "TestLexer" TestLexer.tests,
|
||||||
|
TestLabel "TestParser" TestParser.tests,
|
||||||
|
TestLabel "TestByteCodeGenerator" TestByteCodeGenerator.tests]
|
||||||
|
|
||||||
main = do runTestTTAndExit Main.tests
|
main = do runTestTTAndExit Main.tests
|
@ -8,11 +8,23 @@ executable compiler
|
|||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
build-depends: base,
|
build-depends: base,
|
||||||
array,
|
array,
|
||||||
HUnit
|
HUnit,
|
||||||
|
utf8-string,
|
||||||
|
bytestring
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src,
|
||||||
|
src/ByteCode,
|
||||||
|
src/ByteCode/ClassFile
|
||||||
build-tool-depends: alex:alex, happy:happy
|
build-tool-depends: alex:alex, happy:happy
|
||||||
other-modules: Parser.Lexer, Ast
|
other-modules: Parser.Lexer,
|
||||||
|
Parser.JavaParser
|
||||||
|
Ast,
|
||||||
|
Example,
|
||||||
|
Typecheck,
|
||||||
|
ByteCode.ByteUtil,
|
||||||
|
ByteCode.ClassFile,
|
||||||
|
ByteCode.ClassFile.Generator,
|
||||||
|
ByteCode.Constants
|
||||||
|
|
||||||
test-suite tests
|
test-suite tests
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
@ -20,6 +32,17 @@ test-suite tests
|
|||||||
hs-source-dirs: src,Test
|
hs-source-dirs: src,Test
|
||||||
build-depends: base,
|
build-depends: base,
|
||||||
array,
|
array,
|
||||||
HUnit
|
HUnit,
|
||||||
|
utf8-string,
|
||||||
|
bytestring
|
||||||
build-tool-depends: alex:alex, happy:happy
|
build-tool-depends: alex:alex, happy:happy
|
||||||
other-modules: Parser.Lexer, TestLexer
|
other-modules: Parser.Lexer,
|
||||||
|
Parser.JavaParser,
|
||||||
|
Ast,
|
||||||
|
TestLexer,
|
||||||
|
TestParser,
|
||||||
|
TestByteCodeGenerator,
|
||||||
|
ByteCode.ByteUtil,
|
||||||
|
ByteCode.ClassFile,
|
||||||
|
ByteCode.ClassFile.Generator,
|
||||||
|
ByteCode.Constants
|
||||||
|
2
questions.md
Normal file
2
questions.md
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
# Questions
|
||||||
|
- Enum?
|
97
src/Ast.hs
97
src/Ast.hs
@ -4,51 +4,62 @@ type CompilationUnit = [Class]
|
|||||||
type DataType = String
|
type DataType = String
|
||||||
type Identifier = String
|
type Identifier = String
|
||||||
|
|
||||||
data ParameterDeclaration = ParameterDeclaration DataType Identifier
|
data ParameterDeclaration = ParameterDeclaration DataType Identifier deriving (Show, Eq)
|
||||||
data VariableDeclaration = VariableDeclaration DataType Identifier (Maybe Expression)
|
data VariableDeclaration = VariableDeclaration DataType Identifier (Maybe Expression) deriving (Show, Eq)
|
||||||
data Class = Class DataType [MethodDeclaration] [VariableDeclaration]
|
data Class = Class DataType [MethodDeclaration] [VariableDeclaration] deriving (Show, Eq)
|
||||||
data MethodDeclaration = MethodDeclaration DataType Identifier [ParameterDeclaration] Statement
|
data MethodDeclaration = MethodDeclaration DataType Identifier [ParameterDeclaration] Statement deriving (Show, Eq)
|
||||||
|
|
||||||
data Statement = If Expression Statement (Maybe Statement)
|
data Statement
|
||||||
| LocalVariableDeclaration VariableDeclaration
|
= If Expression Statement (Maybe Statement)
|
||||||
| While Expression Statement
|
| LocalVariableDeclaration VariableDeclaration
|
||||||
| Block [Statement]
|
| While Expression Statement
|
||||||
| Return (Maybe Expression)
|
| Block [Statement]
|
||||||
| StatementExpressionStatement StatementExpression
|
| Return (Maybe Expression)
|
||||||
| TypedStatement DataType Statement
|
| StatementExpressionStatement StatementExpression
|
||||||
|
| TypedStatement DataType Statement
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
data StatementExpression = Assignment Identifier Expression
|
data StatementExpression
|
||||||
| ConstructorCall DataType [Expression]
|
= Assignment Identifier Expression
|
||||||
| MethodCall Identifier [Expression]
|
| ConstructorCall DataType [Expression]
|
||||||
| TypedStatementExpression DataType StatementExpression
|
| MethodCall Expression Identifier [Expression]
|
||||||
|
| TypedStatementExpression DataType StatementExpression
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
data BinaryOperator = Addition
|
data BinaryOperator
|
||||||
| Subtraction
|
= Addition
|
||||||
| Multiplication
|
| Subtraction
|
||||||
| Division
|
| Multiplication
|
||||||
| BitwiseAnd
|
| Division
|
||||||
| BitwiseOr
|
| BitwiseAnd
|
||||||
| BitwiseXor
|
| BitwiseOr
|
||||||
| CompareLessThan
|
| BitwiseXor
|
||||||
| CompareLessOrEqual
|
| CompareLessThan
|
||||||
| CompareGreaterThan
|
| CompareLessOrEqual
|
||||||
| CompareGreaterOrEqual
|
| CompareGreaterThan
|
||||||
| CompareEqual
|
| CompareGreaterOrEqual
|
||||||
| CompareNotEqual
|
| CompareEqual
|
||||||
| And
|
| CompareNotEqual
|
||||||
| Or
|
| And
|
||||||
| NameResolution
|
| Or
|
||||||
|
| NameResolution
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
data UnaryOperator = Not
|
data UnaryOperator
|
||||||
| Minus
|
= Not
|
||||||
|
| Minus
|
||||||
data Expression = IntegerLiteral Int
|
deriving (Show, Eq)
|
||||||
| CharacterLiteral Char
|
|
||||||
| BooleanLiteral Bool
|
|
||||||
| NullLiteral
|
|
||||||
| Reference Identifier
|
|
||||||
| BinaryOperation BinaryOperator Expression Expression
|
|
||||||
| UnaryOperation UnaryOperator Expression
|
|
||||||
| StatementExpressionExpression StatementExpression
|
|
||||||
| TypedExpression DataType Expression
|
|
||||||
|
|
||||||
|
data Expression
|
||||||
|
= IntegerLiteral Int
|
||||||
|
| CharacterLiteral Char
|
||||||
|
| BooleanLiteral Bool
|
||||||
|
| NullLiteral
|
||||||
|
| Reference Identifier
|
||||||
|
| LocalVariable Identifier
|
||||||
|
| FieldVariable Identifier
|
||||||
|
| BinaryOperation BinaryOperator Expression Expression
|
||||||
|
| UnaryOperation UnaryOperator Expression
|
||||||
|
| StatementExpressionExpression StatementExpression
|
||||||
|
| TypedExpression DataType Expression
|
||||||
|
deriving (Show, Eq)
|
||||||
|
19
src/ByteCode/ByteUtil.hs
Normal file
19
src/ByteCode/ByteUtil.hs
Normal file
@ -0,0 +1,19 @@
|
|||||||
|
module ByteCode.ByteUtil(unpackWord16, unpackWord32) where
|
||||||
|
|
||||||
|
import Data.Word ( Word8, Word16, Word32 )
|
||||||
|
import Data.Int
|
||||||
|
import Data.Bits
|
||||||
|
|
||||||
|
unpackWord16 :: Word16 -> [Word8]
|
||||||
|
unpackWord16 v = [
|
||||||
|
fromIntegral (shiftR ((.&.) v 0xFF00) 8),
|
||||||
|
fromIntegral (shiftR ((.&.) v 0x00FF) 0)
|
||||||
|
]
|
||||||
|
|
||||||
|
unpackWord32 :: Word32 -> [Word8]
|
||||||
|
unpackWord32 v = [
|
||||||
|
fromIntegral (shiftR ((.&.) v 0xFF000000) 24),
|
||||||
|
fromIntegral (shiftR ((.&.) v 0x00FF0000) 16),
|
||||||
|
fromIntegral (shiftR ((.&.) v 0x0000FF00) 8),
|
||||||
|
fromIntegral (shiftR ((.&.) v 0x000000FF) 0)
|
||||||
|
]
|
168
src/ByteCode/ClassFile.hs
Normal file
168
src/ByteCode/ClassFile.hs
Normal file
@ -0,0 +1,168 @@
|
|||||||
|
module ByteCode.ClassFile(
|
||||||
|
ConstantInfo(..),
|
||||||
|
Attribute(..),
|
||||||
|
MemberInfo(..),
|
||||||
|
ClassFile(..),
|
||||||
|
Operation(..),
|
||||||
|
serialize,
|
||||||
|
emptyClassFile
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Data.Word
|
||||||
|
import Data.Int
|
||||||
|
import Data.ByteString (unpack)
|
||||||
|
import Data.ByteString.UTF8 (fromString)
|
||||||
|
import ByteCode.ByteUtil
|
||||||
|
import ByteCode.Constants
|
||||||
|
|
||||||
|
data ConstantInfo = ClassInfo Word16
|
||||||
|
| FieldRefInfo Word16 Word16
|
||||||
|
| MethodRefInfo Word16 Word16
|
||||||
|
| NameAndTypeInfo Word16 Word16
|
||||||
|
| IntegerInfo Int32
|
||||||
|
| Utf8Info [Char]
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
data Operation = Opiadd
|
||||||
|
| Opisub
|
||||||
|
| Opimul
|
||||||
|
| Opidiv
|
||||||
|
| Opiand
|
||||||
|
| Opior
|
||||||
|
| Opixor
|
||||||
|
| Opineg
|
||||||
|
| Opif_icmplt Word16
|
||||||
|
| Opif_icmple Word16
|
||||||
|
| Opif_icmpgt Word16
|
||||||
|
| Opif_icmpge Word16
|
||||||
|
| Opif_icmpeq Word16
|
||||||
|
| Opif_icmpne Word16
|
||||||
|
| Opaconst_null
|
||||||
|
| Opreturn
|
||||||
|
| Opireturn
|
||||||
|
| Opareturn
|
||||||
|
| Opsipush Word16
|
||||||
|
| Opldc_w Word16
|
||||||
|
| Opaload Word16
|
||||||
|
| Opiload Word16
|
||||||
|
| Opastore Word16
|
||||||
|
| Opistore Word16
|
||||||
|
| Opputfield Word16
|
||||||
|
| OpgetField Word16
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
|
||||||
|
data Attribute = CodeAttribute {
|
||||||
|
attributeMaxStack :: Word16,
|
||||||
|
attributeMaxLocals :: Word16,
|
||||||
|
attributeCode :: [Operation]
|
||||||
|
} deriving (Show, Eq)
|
||||||
|
|
||||||
|
|
||||||
|
data MemberInfo = MemberInfo {
|
||||||
|
memberAccessFlags :: Word16,
|
||||||
|
memberNameIndex :: Word16,
|
||||||
|
memberDescriptorIndex :: Word16,
|
||||||
|
memberAttributes :: [Attribute]
|
||||||
|
} deriving (Show, Eq)
|
||||||
|
|
||||||
|
data ClassFile = ClassFile {
|
||||||
|
constantPool :: [ConstantInfo],
|
||||||
|
accessFlags :: Word16,
|
||||||
|
thisClass :: Word16,
|
||||||
|
superClass :: Word16,
|
||||||
|
fields :: [MemberInfo],
|
||||||
|
methods :: [MemberInfo],
|
||||||
|
attributes :: [Attribute]
|
||||||
|
} deriving (Show, Eq)
|
||||||
|
|
||||||
|
emptyClassFile :: ClassFile
|
||||||
|
emptyClassFile = ClassFile {
|
||||||
|
constantPool = [],
|
||||||
|
accessFlags = accessPublic,
|
||||||
|
thisClass = 0,
|
||||||
|
superClass = 0,
|
||||||
|
fields = [],
|
||||||
|
methods = [],
|
||||||
|
attributes = []
|
||||||
|
}
|
||||||
|
|
||||||
|
class Serializable a where
|
||||||
|
serialize :: a -> [Word8]
|
||||||
|
|
||||||
|
instance Serializable ConstantInfo where
|
||||||
|
serialize (ClassInfo nameIndex) = tagClass : unpackWord16 nameIndex
|
||||||
|
serialize (FieldRefInfo classIndex nameAndTypeIndex) = tagFieldref : (unpackWord16 classIndex ++ unpackWord16 nameAndTypeIndex)
|
||||||
|
serialize (MethodRefInfo classIndex nameAndTypeIndex) = tagMethodref : (unpackWord16 classIndex ++ unpackWord16 nameAndTypeIndex)
|
||||||
|
serialize (NameAndTypeInfo classIndex descriptorIndex) = tagNameandtype : (unpackWord16 classIndex ++ unpackWord16 descriptorIndex)
|
||||||
|
serialize (IntegerInfo value) = tagInteger : unpackWord32 (fromIntegral value)
|
||||||
|
serialize (Utf8Info string) = tagUtf8 : unpackWord16 num_bytes ++ bytes where
|
||||||
|
bytes = unpack (fromString string)
|
||||||
|
num_bytes = fromIntegral $ length bytes
|
||||||
|
|
||||||
|
instance Serializable MemberInfo where
|
||||||
|
serialize member = unpackWord16 (memberAccessFlags member)
|
||||||
|
++ unpackWord16 (memberNameIndex member)
|
||||||
|
++ unpackWord16 (memberDescriptorIndex member)
|
||||||
|
++ unpackWord16 (fromIntegral (length (memberAttributes member)))
|
||||||
|
++ concatMap serialize (memberAttributes member)
|
||||||
|
|
||||||
|
instance Serializable Operation where
|
||||||
|
serialize Opiadd = [0x60]
|
||||||
|
serialize Opisub = [0x64]
|
||||||
|
serialize Opimul = [0x68]
|
||||||
|
serialize Opidiv = [0x6C]
|
||||||
|
serialize Opiand = [0x7E]
|
||||||
|
serialize Opior = [0x80]
|
||||||
|
serialize Opixor = [0x82]
|
||||||
|
serialize Opineg = [0x74]
|
||||||
|
serialize (Opif_icmplt branch) = 0xA1 : unpackWord16 branch
|
||||||
|
serialize (Opif_icmple branch) = 0xA4 : unpackWord16 branch
|
||||||
|
serialize (Opif_icmpgt branch) = 0xA3 : unpackWord16 branch
|
||||||
|
serialize (Opif_icmpge branch) = 0xA2 : unpackWord16 branch
|
||||||
|
serialize (Opif_icmpeq branch) = 0x9F : unpackWord16 branch
|
||||||
|
serialize (Opif_icmpne branch) = 0xA0 : unpackWord16 branch
|
||||||
|
serialize Opaconst_null = [0x01]
|
||||||
|
serialize Opreturn = [0xB1]
|
||||||
|
serialize Opireturn = [0xAC]
|
||||||
|
serialize Opareturn = [0xB0]
|
||||||
|
serialize (Opsipush index) = 0x11 : unpackWord16 index
|
||||||
|
serialize (Opldc_w index) = 0x13 : unpackWord16 index
|
||||||
|
serialize (Opaload index) = [0xC4, 0x19] ++ unpackWord16 index
|
||||||
|
serialize (Opiload index) = [0xC4, 0x15] ++ unpackWord16 index
|
||||||
|
serialize (Opastore index) = [0xC4, 0x3A] ++ unpackWord16 index
|
||||||
|
serialize (Opistore index) = [0xC4, 0x36] ++ unpackWord16 index
|
||||||
|
serialize (Opputfield index) = 0xB5 : unpackWord16 index
|
||||||
|
serialize (OpgetField index) = 0xB4 : unpackWord16 index
|
||||||
|
|
||||||
|
instance Serializable Attribute where
|
||||||
|
serialize (CodeAttribute { attributeMaxStack = maxStack,
|
||||||
|
attributeMaxLocals = maxLocals,
|
||||||
|
attributeCode = code }) = let
|
||||||
|
assembledCode = concat (map serialize code)
|
||||||
|
in
|
||||||
|
unpackWord16 7 -- attribute_name_index
|
||||||
|
++ unpackWord32 (12 + (fromIntegral (length assembledCode))) -- attribute_length
|
||||||
|
++ unpackWord16 maxStack -- max_stack
|
||||||
|
++ unpackWord16 maxLocals -- max_locals
|
||||||
|
++ unpackWord32 (fromIntegral (length assembledCode)) -- code_length
|
||||||
|
++ assembledCode -- code
|
||||||
|
++ unpackWord16 0 -- exception_table_length
|
||||||
|
++ unpackWord16 0 -- attributes_count
|
||||||
|
|
||||||
|
instance Serializable ClassFile where
|
||||||
|
serialize classfile = unpackWord32 0xC0FEBABE -- magic
|
||||||
|
++ unpackWord16 0 -- minor version
|
||||||
|
++ unpackWord16 49 -- major version
|
||||||
|
++ unpackWord16 (fromIntegral (1 + length (constantPool classfile))) -- constant pool count
|
||||||
|
++ concatMap serialize (constantPool classfile) -- constant pool
|
||||||
|
++ unpackWord16 (accessFlags classfile) -- access flags
|
||||||
|
++ unpackWord16 (thisClass classfile) -- this class
|
||||||
|
++ unpackWord16 (superClass classfile) -- super class
|
||||||
|
++ unpackWord16 0 -- interface count
|
||||||
|
++ unpackWord16 (fromIntegral (length (fields classfile))) -- fields count
|
||||||
|
++ concatMap serialize (fields classfile) -- fields info
|
||||||
|
++ unpackWord16 (fromIntegral (length (methods classfile))) -- methods count
|
||||||
|
++ concatMap serialize (methods classfile) -- methods info
|
||||||
|
++ unpackWord16 (fromIntegral (length (attributes classfile))) -- attributes count
|
||||||
|
++ concatMap serialize (attributes classfile) -- attributes info
|
169
src/ByteCode/ClassFile/Generator.hs
Normal file
169
src/ByteCode/ClassFile/Generator.hs
Normal file
@ -0,0 +1,169 @@
|
|||||||
|
module ByteCode.ClassFile.Generator(
|
||||||
|
classBuilder,
|
||||||
|
datatypeDescriptor,
|
||||||
|
methodParameterDescriptor,
|
||||||
|
methodDescriptor,
|
||||||
|
) where
|
||||||
|
|
||||||
|
import ByteCode.Constants
|
||||||
|
import ByteCode.ClassFile (ClassFile (..), ConstantInfo (..), MemberInfo(..), Operation(..), Attribute(..))
|
||||||
|
import Ast
|
||||||
|
import Data.Char
|
||||||
|
|
||||||
|
|
||||||
|
type ClassFileBuilder a = a -> ClassFile -> ClassFile
|
||||||
|
|
||||||
|
|
||||||
|
datatypeDescriptor :: String -> String
|
||||||
|
datatypeDescriptor "void" = "V"
|
||||||
|
datatypeDescriptor "int" = "I"
|
||||||
|
datatypeDescriptor "char" = "C"
|
||||||
|
datatypeDescriptor "boolean" = "B"
|
||||||
|
datatypeDescriptor x = "L" ++ x
|
||||||
|
|
||||||
|
methodParameterDescriptor :: String -> String
|
||||||
|
methodParameterDescriptor "void" = "V"
|
||||||
|
methodParameterDescriptor "int" = "I"
|
||||||
|
methodParameterDescriptor "char" = "C"
|
||||||
|
methodParameterDescriptor "boolean" = "B"
|
||||||
|
methodParameterDescriptor x = "L" ++ x ++ ";"
|
||||||
|
|
||||||
|
methodDescriptor :: MethodDeclaration -> String
|
||||||
|
methodDescriptor (MethodDeclaration returntype _ parameters _) = let
|
||||||
|
parameter_types = [datatype | ParameterDeclaration datatype _ <- parameters]
|
||||||
|
in
|
||||||
|
"("
|
||||||
|
++ (concat (map methodParameterDescriptor parameter_types))
|
||||||
|
++ ")"
|
||||||
|
++ datatypeDescriptor returntype
|
||||||
|
|
||||||
|
classBuilder :: ClassFileBuilder Class
|
||||||
|
classBuilder (Class name methods fields) _ = let
|
||||||
|
baseConstants = [
|
||||||
|
ClassInfo 4,
|
||||||
|
MethodRefInfo 1 3,
|
||||||
|
NameAndTypeInfo 5 6,
|
||||||
|
Utf8Info "java/lang/Object",
|
||||||
|
Utf8Info "<init>",
|
||||||
|
Utf8Info "()V",
|
||||||
|
Utf8Info "Code"
|
||||||
|
]
|
||||||
|
nameConstants = [ClassInfo 9, Utf8Info name]
|
||||||
|
nakedClassFile = ClassFile {
|
||||||
|
constantPool = baseConstants ++ nameConstants,
|
||||||
|
accessFlags = accessPublic,
|
||||||
|
thisClass = 8,
|
||||||
|
superClass = 1,
|
||||||
|
fields = [],
|
||||||
|
methods = [],
|
||||||
|
attributes = []
|
||||||
|
}
|
||||||
|
in
|
||||||
|
foldr methodBuilder (foldr fieldBuilder nakedClassFile fields) methods
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
fieldBuilder :: ClassFileBuilder VariableDeclaration
|
||||||
|
fieldBuilder (VariableDeclaration datatype name _) input = let
|
||||||
|
baseIndex = 1 + length (constantPool input)
|
||||||
|
constants = [
|
||||||
|
FieldRefInfo (fromIntegral (thisClass input)) (fromIntegral (baseIndex + 1)),
|
||||||
|
NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
|
||||||
|
Utf8Info name,
|
||||||
|
Utf8Info (datatypeDescriptor datatype)
|
||||||
|
]
|
||||||
|
field = MemberInfo {
|
||||||
|
memberAccessFlags = accessPublic,
|
||||||
|
memberNameIndex = (fromIntegral (baseIndex + 2)),
|
||||||
|
memberDescriptorIndex = (fromIntegral (baseIndex + 3)),
|
||||||
|
memberAttributes = []
|
||||||
|
}
|
||||||
|
in
|
||||||
|
input {
|
||||||
|
constantPool = (constantPool input) ++ constants,
|
||||||
|
fields = (fields input) ++ [field]
|
||||||
|
}
|
||||||
|
|
||||||
|
methodBuilder :: ClassFileBuilder MethodDeclaration
|
||||||
|
methodBuilder (MethodDeclaration returntype name parameters statement) input = let
|
||||||
|
baseIndex = 1 + length (constantPool input)
|
||||||
|
constants = [
|
||||||
|
FieldRefInfo (fromIntegral (thisClass input)) (fromIntegral (baseIndex + 1)),
|
||||||
|
NameAndTypeInfo (fromIntegral (baseIndex + 2)) (fromIntegral (baseIndex + 3)),
|
||||||
|
Utf8Info name,
|
||||||
|
Utf8Info (methodDescriptor (MethodDeclaration returntype name parameters (Block [])))
|
||||||
|
]
|
||||||
|
--code = assembleByteCode statement
|
||||||
|
method = MemberInfo {
|
||||||
|
memberAccessFlags = accessPublic,
|
||||||
|
memberNameIndex = (fromIntegral (baseIndex + 2)),
|
||||||
|
memberDescriptorIndex = (fromIntegral (baseIndex + 3)),
|
||||||
|
memberAttributes = [
|
||||||
|
CodeAttribute {
|
||||||
|
attributeMaxStack = 420,
|
||||||
|
attributeMaxLocals = 420,
|
||||||
|
attributeCode = [Opiadd]
|
||||||
|
}
|
||||||
|
]
|
||||||
|
}
|
||||||
|
in
|
||||||
|
input {
|
||||||
|
constantPool = (constantPool input) ++ constants,
|
||||||
|
methods = (fields input) ++ [method]
|
||||||
|
}
|
||||||
|
|
||||||
|
type Assembler a = a -> ([ConstantInfo], [Operation]) -> ([ConstantInfo], [Operation])
|
||||||
|
|
||||||
|
returnOperation :: DataType -> Operation
|
||||||
|
returnOperation dtype
|
||||||
|
| elem dtype ["int", "char", "boolean"] = Opireturn
|
||||||
|
| otherwise = Opareturn
|
||||||
|
|
||||||
|
binaryOperation :: BinaryOperator -> Operation
|
||||||
|
binaryOperation Addition = Opiadd
|
||||||
|
binaryOperation Subtraction = Opisub
|
||||||
|
binaryOperation Multiplication = Opimul
|
||||||
|
binaryOperation Division = Opidiv
|
||||||
|
binaryOperation BitwiseAnd = Opiand
|
||||||
|
binaryOperation BitwiseOr = Opior
|
||||||
|
binaryOperation BitwiseXor = Opixor
|
||||||
|
|
||||||
|
assembleMethod :: Assembler MethodDeclaration
|
||||||
|
assembleMethod (MethodDeclaration _ _ _ (Block statements)) (constants, ops) =
|
||||||
|
foldr assembleStatement (constants, ops) statements
|
||||||
|
|
||||||
|
assembleStatement :: Assembler Statement
|
||||||
|
assembleStatement (TypedStatement stype (Return expr)) (constants, ops) = case expr of
|
||||||
|
Nothing -> (constants, ops ++ [Opreturn])
|
||||||
|
Just expr -> let
|
||||||
|
(expr_constants, expr_ops) = assembleExpression expr (constants, ops)
|
||||||
|
in
|
||||||
|
(expr_constants, expr_ops ++ [returnOperation stype])
|
||||||
|
|
||||||
|
assembleExpression :: Assembler Expression
|
||||||
|
assembleExpression (TypedExpression _ (BinaryOperation op a b)) (constants, ops)
|
||||||
|
| elem op [Addition, Subtraction, Multiplication, Division, BitwiseAnd, BitwiseOr, BitwiseXor] = let
|
||||||
|
(aConstants, aOps) = assembleExpression a (constants, ops)
|
||||||
|
(bConstants, bOps) = assembleExpression b (aConstants, aOps)
|
||||||
|
in
|
||||||
|
(bConstants, bOps ++ [binaryOperation op])
|
||||||
|
assembleExpression (TypedExpression _ (CharacterLiteral literal)) (constants, ops) =
|
||||||
|
(constants, ops ++ [Opsipush (fromIntegral (ord literal))])
|
||||||
|
assembleExpression (TypedExpression _ (BooleanLiteral literal)) (constants, ops) =
|
||||||
|
(constants, ops ++ [Opsipush (if literal then 1 else 0)])
|
||||||
|
assembleExpression (TypedExpression _ (IntegerLiteral literal)) (constants, ops)
|
||||||
|
| literal <= 32767 && literal >= -32768 = (constants, ops ++ [Opsipush (fromIntegral literal)])
|
||||||
|
| otherwise = (constants ++ [IntegerInfo (fromIntegral literal)], ops ++ [Opldc_w (fromIntegral (1 + length constants))])
|
||||||
|
assembleExpression (TypedExpression _ NullLiteral) (constants, ops) =
|
||||||
|
(constants, ops ++ [Opaconst_null])
|
||||||
|
assembleExpression (TypedExpression etype (UnaryOperation Not expr)) (constants, ops) = let
|
||||||
|
(exprConstants, exprOps) = assembleExpression expr (constants, ops)
|
||||||
|
newConstant = fromIntegral (1 + length exprConstants)
|
||||||
|
in case etype of
|
||||||
|
"int" -> (exprConstants ++ [IntegerInfo 0x7FFFFFFF], exprOps ++ [Opldc_w newConstant, Opixor])
|
||||||
|
"char" -> (exprConstants, exprOps ++ [Opsipush 0xFFFF, Opixor])
|
||||||
|
"boolean" -> (exprConstants, exprOps ++ [Opsipush 0x01, Opixor])
|
||||||
|
assembleExpression (TypedExpression _ (UnaryOperation Minus expr)) (constants, ops) = let
|
||||||
|
(exprConstants, exprOps) = assembleExpression expr (constants, ops)
|
||||||
|
in
|
||||||
|
(exprConstants, exprOps ++ [Opineg])
|
25
src/ByteCode/Constants.hs
Normal file
25
src/ByteCode/Constants.hs
Normal file
@ -0,0 +1,25 @@
|
|||||||
|
module ByteCode.Constants where
|
||||||
|
import Data.Word
|
||||||
|
|
||||||
|
|
||||||
|
tagClass :: Word8
|
||||||
|
tagFieldref :: Word8
|
||||||
|
tagMethodref :: Word8
|
||||||
|
tagNameandtype :: Word8
|
||||||
|
tagInteger :: Word8
|
||||||
|
tagUtf8 :: Word8
|
||||||
|
|
||||||
|
accessPublic :: Word16
|
||||||
|
accessPrivate :: Word16
|
||||||
|
accessProtected :: Word16
|
||||||
|
|
||||||
|
tagClass = 0x07
|
||||||
|
tagFieldref = 0x09
|
||||||
|
tagMethodref = 0x0A
|
||||||
|
tagNameandtype = 0x0C
|
||||||
|
tagInteger = 0x03
|
||||||
|
tagUtf8 = 0x01
|
||||||
|
|
||||||
|
accessPublic = 0x01
|
||||||
|
accessPrivate = 0x02
|
||||||
|
accessProtected = 0x04
|
203
src/Example.hs
Normal file
203
src/Example.hs
Normal file
@ -0,0 +1,203 @@
|
|||||||
|
module Example where
|
||||||
|
|
||||||
|
import Ast
|
||||||
|
import Typecheck
|
||||||
|
import Control.Exception (catch, evaluate, SomeException, displayException)
|
||||||
|
import Control.Exception.Base
|
||||||
|
import System.IO (stderr, hPutStrLn)
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.List
|
||||||
|
|
||||||
|
green, red, yellow, blue, magenta, cyan, white :: String -> String
|
||||||
|
green str = "\x1b[32m" ++ str ++ "\x1b[0m"
|
||||||
|
red str = "\x1b[31m" ++ str ++ "\x1b[0m"
|
||||||
|
yellow str = "\x1b[33m" ++ str ++ "\x1b[0m"
|
||||||
|
blue str = "\x1b[34m" ++ str ++ "\x1b[0m"
|
||||||
|
magenta str = "\x1b[35m" ++ str ++ "\x1b[0m"
|
||||||
|
cyan str = "\x1b[36m" ++ str ++ "\x1b[0m"
|
||||||
|
white str = "\x1b[37m" ++ str ++ "\x1b[0m"
|
||||||
|
|
||||||
|
printSuccess :: String -> IO ()
|
||||||
|
printSuccess msg = putStrLn $ green "Success:" ++ white msg
|
||||||
|
|
||||||
|
handleError :: SomeException -> IO ()
|
||||||
|
handleError e = hPutStrLn stderr $ red ("Error: " ++ displayException e)
|
||||||
|
|
||||||
|
printResult :: Show a => String -> a -> IO ()
|
||||||
|
printResult title result = do
|
||||||
|
putStrLn $ green title
|
||||||
|
print result
|
||||||
|
|
||||||
|
sampleClasses :: [Class]
|
||||||
|
sampleClasses = [
|
||||||
|
Class "Person" [
|
||||||
|
MethodDeclaration "void" "setAge" [ParameterDeclaration "int" "newAge"]
|
||||||
|
(Block [
|
||||||
|
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (Reference "newAge")))
|
||||||
|
]),
|
||||||
|
MethodDeclaration "int" "getAge" [] (Return (Just (Reference "age"))),
|
||||||
|
MethodDeclaration "Person" "Person" [ParameterDeclaration "int" "initialAge"] (Block [])
|
||||||
|
] [
|
||||||
|
VariableDeclaration "int" "age" (Just (IntegerLiteral 25))
|
||||||
|
]
|
||||||
|
]
|
||||||
|
|
||||||
|
initialSymtab :: [(DataType, Identifier)]
|
||||||
|
initialSymtab = []
|
||||||
|
|
||||||
|
exampleExpression :: Expression
|
||||||
|
exampleExpression = BinaryOperation NameResolution (Reference "bob") (Reference "age")
|
||||||
|
|
||||||
|
exampleAssignment :: Expression
|
||||||
|
exampleAssignment = StatementExpressionExpression (Assignment "a" (IntegerLiteral 30))
|
||||||
|
|
||||||
|
exampleMethodCall :: Statement
|
||||||
|
exampleMethodCall = StatementExpressionStatement (MethodCall (Reference "this") "setAge" [IntegerLiteral 30])
|
||||||
|
|
||||||
|
exampleConstructorCall :: Statement
|
||||||
|
exampleConstructorCall = LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30]))))
|
||||||
|
|
||||||
|
exampleNameResolution :: Expression
|
||||||
|
exampleNameResolution = BinaryOperation NameResolution (Reference "b") (Reference "age")
|
||||||
|
|
||||||
|
exampleBlockResolution :: Statement
|
||||||
|
exampleBlockResolution = Block [
|
||||||
|
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
|
||||||
|
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
|
||||||
|
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30])
|
||||||
|
]
|
||||||
|
|
||||||
|
exampleBlockResolutionFail :: Statement
|
||||||
|
exampleBlockResolutionFail = Block [
|
||||||
|
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
|
||||||
|
LocalVariableDeclaration (VariableDeclaration "bool" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
|
||||||
|
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30])
|
||||||
|
]
|
||||||
|
|
||||||
|
exampleMethodCallAndAssignment :: Statement
|
||||||
|
exampleMethodCallAndAssignment = Block [
|
||||||
|
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
|
||||||
|
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
|
||||||
|
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
|
||||||
|
LocalVariableDeclaration (VariableDeclaration "int" "a" Nothing),
|
||||||
|
StatementExpressionStatement (Assignment "a" (Reference "age"))
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
exampleMethodCallAndAssignmentFail :: Statement
|
||||||
|
exampleMethodCallAndAssignmentFail = Block [
|
||||||
|
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 30])))),
|
||||||
|
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
|
||||||
|
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
|
||||||
|
StatementExpressionStatement (Assignment "a" (Reference "age"))
|
||||||
|
]
|
||||||
|
|
||||||
|
testClasses :: [Class]
|
||||||
|
testClasses = [
|
||||||
|
Class "Person" [
|
||||||
|
MethodDeclaration "Person" "Person" [ParameterDeclaration "int" "initialAge"]
|
||||||
|
(Block [
|
||||||
|
Return (Just (Reference "this"))
|
||||||
|
]),
|
||||||
|
MethodDeclaration "void" "setAge" [ParameterDeclaration "int" "newAge"]
|
||||||
|
(Block [
|
||||||
|
LocalVariableDeclaration (VariableDeclaration "int" "age" (Just (Reference "newAge")))
|
||||||
|
]),
|
||||||
|
MethodDeclaration "int" "getAge" []
|
||||||
|
(Return (Just (Reference "age")))
|
||||||
|
] [
|
||||||
|
VariableDeclaration "int" "age" Nothing -- initially unassigned
|
||||||
|
],
|
||||||
|
Class "Main" [
|
||||||
|
MethodDeclaration "int" "main" []
|
||||||
|
(Block [
|
||||||
|
LocalVariableDeclaration (VariableDeclaration "Person" "bob" (Just (StatementExpressionExpression (ConstructorCall "Person" [IntegerLiteral 25])))),
|
||||||
|
StatementExpressionStatement (MethodCall (Reference "bob") "setAge" [IntegerLiteral 30]),
|
||||||
|
LocalVariableDeclaration (VariableDeclaration "int" "bobAge" (Just (StatementExpressionExpression (MethodCall (Reference "bob") "getAge" [])))),
|
||||||
|
Return (Just (Reference "bobAge"))
|
||||||
|
])
|
||||||
|
] []
|
||||||
|
]
|
||||||
|
|
||||||
|
runTypeCheck :: IO ()
|
||||||
|
runTypeCheck = do
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
evaluatedExpression <- evaluate (typeCheckExpression exampleExpression [("bob", "Person")] sampleClasses)
|
||||||
|
printSuccess "Type checking of expression completed successfully"
|
||||||
|
printResult "Result Expression:" evaluatedExpression
|
||||||
|
) handleError
|
||||||
|
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
evaluatedAssignment <- evaluate (typeCheckExpression exampleAssignment [("a", "int")] sampleClasses)
|
||||||
|
printSuccess "Type checking of assignment completed successfully"
|
||||||
|
printResult "Result Assignment:" evaluatedAssignment
|
||||||
|
) handleError
|
||||||
|
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
evaluatedMethodCall <- evaluate (typeCheckStatement exampleMethodCall [("this", "Person"), ("setAge", "Person"), ("getAge", "Person")] sampleClasses)
|
||||||
|
printSuccess "Type checking of method call this completed successfully"
|
||||||
|
printResult "Result MethodCall:" evaluatedMethodCall
|
||||||
|
) handleError
|
||||||
|
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
evaluatedConstructorCall <- evaluate (typeCheckStatement exampleConstructorCall [] sampleClasses)
|
||||||
|
printSuccess "Type checking of constructor call completed successfully"
|
||||||
|
printResult "Result Constructor Call:" evaluatedConstructorCall
|
||||||
|
) handleError
|
||||||
|
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
evaluatedNameResolution <- evaluate (typeCheckExpression exampleNameResolution [("b", "Person")] sampleClasses)
|
||||||
|
printSuccess "Type checking of name resolution completed successfully"
|
||||||
|
printResult "Result Name Resolution:" evaluatedNameResolution
|
||||||
|
) handleError
|
||||||
|
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
evaluatedBlockResolution <- evaluate (typeCheckStatement exampleBlockResolution [] sampleClasses)
|
||||||
|
printSuccess "Type checking of block resolution completed successfully"
|
||||||
|
printResult "Result Block Resolution:" evaluatedBlockResolution
|
||||||
|
) handleError
|
||||||
|
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
evaluatedBlockResolutionFail <- evaluate (typeCheckStatement exampleBlockResolutionFail [] sampleClasses)
|
||||||
|
printSuccess "Type checking of block resolution failed"
|
||||||
|
printResult "Result Block Resolution:" evaluatedBlockResolutionFail
|
||||||
|
) handleError
|
||||||
|
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
evaluatedMethodCallAndAssignment <- evaluate (typeCheckStatement exampleMethodCallAndAssignment [] sampleClasses)
|
||||||
|
printSuccess "Type checking of method call and assignment completed successfully"
|
||||||
|
printResult "Result Method Call and Assignment:" evaluatedMethodCallAndAssignment
|
||||||
|
) handleError
|
||||||
|
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
evaluatedMethodCallAndAssignmentFail <- evaluate (typeCheckStatement exampleMethodCallAndAssignmentFail [] sampleClasses)
|
||||||
|
printSuccess "Type checking of method call and assignment failed"
|
||||||
|
printResult "Result Method Call and Assignment:" evaluatedMethodCallAndAssignmentFail
|
||||||
|
) handleError
|
||||||
|
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
let mainClass = fromJust $ find (\(Class className _ _) -> className == "Main") testClasses
|
||||||
|
case mainClass of
|
||||||
|
Class _ [mainMethod] _ -> do
|
||||||
|
let result = typeCheckMethodDeclaration mainMethod [] testClasses
|
||||||
|
printSuccess "Full program type checking completed successfully."
|
||||||
|
printResult "Main method result:" result
|
||||||
|
) handleError
|
||||||
|
|
||||||
|
catch (do
|
||||||
|
print "====================================================================================="
|
||||||
|
let typedProgram = typeCheckCompilationUnit testClasses
|
||||||
|
printSuccess "Type checking of Program completed successfully"
|
||||||
|
printResult "Typed Program:" typedProgram
|
||||||
|
) handleError
|
||||||
|
|
@ -1,6 +1,8 @@
|
|||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Parser.Lexer
|
import Example
|
||||||
|
import Typecheck
|
||||||
|
|
||||||
main = do
|
main = do
|
||||||
print $ alexScanTokens "/**/"
|
Example.runTypeCheck
|
||||||
|
|
||||||
|
@ -1,6 +1,6 @@
|
|||||||
{
|
{
|
||||||
module Parser.JavaParser (parse) where
|
module Parser.JavaParser (parse) where
|
||||||
--import AbsSyn
|
import Ast
|
||||||
import Parser.Lexer
|
import Parser.Lexer
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -14,10 +14,10 @@ import Parser.Lexer
|
|||||||
CASE { CASE }
|
CASE { CASE }
|
||||||
CHAR { CHAR }
|
CHAR { CHAR }
|
||||||
CLASS { CLASS}
|
CLASS { CLASS}
|
||||||
IDENTIFIER { IDENTIFIER $$}
|
IDENTIFIER { IDENTIFIER $$ }
|
||||||
INTLITERAL { INTLITERAL $$}
|
INTLITERAL { INTEGERLITERAL $$}
|
||||||
DOT { DOT }
|
DOT { DOT }
|
||||||
MOD { MOD }
|
MOD { MODULO }
|
||||||
TIMESEQUAL { TIMESEQUAL }
|
TIMESEQUAL { TIMESEQUAL }
|
||||||
GREATEREQUAL { GREATEREQUAL }
|
GREATEREQUAL { GREATEREQUAL }
|
||||||
WHILE { WHILE }
|
WHILE { WHILE }
|
||||||
@ -29,30 +29,29 @@ import Parser.Lexer
|
|||||||
THIS { THIS }
|
THIS { THIS }
|
||||||
STATIC { STATIC }
|
STATIC { STATIC }
|
||||||
PROTECTED { PROTECTED }
|
PROTECTED { PROTECTED }
|
||||||
TILDE { TILDE }
|
TILDE { BITWISENOT }
|
||||||
MUL { MUL }
|
MUL { TIMES }
|
||||||
MINUS { MINUS }
|
MINUS { MINUS }
|
||||||
EXCLMARK { EXCLMARK }
|
EXCLMARK { NOT }
|
||||||
IF { IF }
|
IF { IF }
|
||||||
ELSE { ELSE }
|
ELSE { ELSE }
|
||||||
DIVIDEEQUAL { DIVIDEEQUAL }
|
DIVIDEEQUAL { DIVEQUAL }
|
||||||
NEW { NEW }
|
NEW { NEW }
|
||||||
LBRACKET { LBRACKET }
|
LBRACKET { LBRACKET }
|
||||||
JNULL { JNULL }
|
JNULL { NULLLITERAL }
|
||||||
BOOLLITERAL { BOOLLITERAL }
|
BOOLLITERAL { BOOLLITERAL $$ }
|
||||||
DIV { DIV }
|
DIV { DIV }
|
||||||
LOGICALOR { LOGICALOR }
|
LOGICALOR { OR }
|
||||||
NOTEQUAL { NOTEQUAL }
|
NOTEQUAL { NOTEQUAL }
|
||||||
INSTANCEOF { INSTANCEOF }
|
INSTANCEOF { INSTANCEOF }
|
||||||
ANDEQUAL { ANDEQUAL }
|
ANDEQUAL { ANDEQUAL }
|
||||||
ASSIGN { ASSIGN }
|
ASSIGN { ASSIGN }
|
||||||
DECREMENT { DECREMENT }
|
DECREMENT { DECREMENT }
|
||||||
STRINGLITERAL { STRINGLITERAL }
|
CHARLITERAL { CHARLITERAL $$ }
|
||||||
CHARLITERAL { CHARLITERAL }
|
|
||||||
AND { AND }
|
AND { AND }
|
||||||
XOREQUAL { XOREQUAL }
|
XOREQUAL { XOREQUAL }
|
||||||
RETURN { RETURN }
|
RETURN { RETURN }
|
||||||
QUESMARK { QUESMARK }
|
QUESMARK { QUESTIONMARK }
|
||||||
SHIFTLEFTEQUAL { SHIFTLEFTEQUAL }
|
SHIFTLEFTEQUAL { SHIFTLEFTEQUAL }
|
||||||
RBRACKET { RBRACKET }
|
RBRACKET { RBRACKET }
|
||||||
COMMA { COMMA }
|
COMMA { COMMA }
|
||||||
@ -68,7 +67,7 @@ import Parser.Lexer
|
|||||||
INT { INT }
|
INT { INT }
|
||||||
ABSTRACT { ABSTRACT }
|
ABSTRACT { ABSTRACT }
|
||||||
SEMICOLON { SEMICOLON }
|
SEMICOLON { SEMICOLON }
|
||||||
SIGNEDSHIFTRIGHTEQUAL { SIGNEDSHIFTRIGHTEQUAL }
|
SIGNEDSHIFTRIGHTEQUAL { SHIFTRIGHTEQUAL }
|
||||||
UNSIGNEDSHIFTRIGHTEQUAL { UNSIGNEDSHIFTRIGHTEQUAL }
|
UNSIGNEDSHIFTRIGHTEQUAL { UNSIGNEDSHIFTRIGHTEQUAL }
|
||||||
PLUSEQUAL { PLUSEQUAL }
|
PLUSEQUAL { PLUSEQUAL }
|
||||||
OREQUAL { OREQUAL }
|
OREQUAL { OREQUAL }
|
||||||
@ -76,138 +75,146 @@ import Parser.Lexer
|
|||||||
LESS { LESS }
|
LESS { LESS }
|
||||||
%%
|
%%
|
||||||
|
|
||||||
compilationunit : typedeclarations { }
|
compilationunit : typedeclarations { $1 }
|
||||||
|
|
||||||
typedeclarations : typedeclaration { }
|
typedeclarations : typedeclaration { [$1] }
|
||||||
| typedeclarations typedeclaration { }
|
| typedeclarations typedeclaration { $1 ++ [$2] }
|
||||||
|
|
||||||
name : qualifiedname { }
|
name : qualifiedname { }
|
||||||
| simplename { }
|
| simplename { }
|
||||||
|
|
||||||
typedeclaration : classdeclaration { }
|
typedeclaration : classdeclaration { $1 }
|
||||||
|
|
||||||
qualifiedname : name DOT IDENTIFIER { }
|
qualifiedname : name DOT IDENTIFIER { }
|
||||||
|
|
||||||
simplename : IDENTIFIER { }
|
simplename : IDENTIFIER { }
|
||||||
|
|
||||||
classdeclaration : CLASS IDENTIFIER classbody { }
|
classdeclaration : CLASS IDENTIFIER classbody { case $3 of (methods, fields) -> Class $2 methods fields }
|
||||||
| modifiers CLASS IDENTIFIER classbody { }
|
-- | modifiers CLASS IDENTIFIER classbody { case $4 of (methods, fields) -> Class $3 methods fields }
|
||||||
|
|
||||||
classbody : LBRACKET RBRACKET { ([], []) }
|
classbody : LBRACKET RBRACKET { ([], []) }
|
||||||
| LBRACKET classbodydeclarations RBRACKET { }
|
| LBRACKET classbodydeclarations RBRACKET { $2 }
|
||||||
|
|
||||||
modifiers : modifier { }
|
modifiers : modifier { }
|
||||||
| modifiers modifier { }
|
| modifiers modifier { }
|
||||||
|
|
||||||
classbodydeclarations : classbodydeclaration { }
|
classbodydeclarations : classbodydeclaration {
|
||||||
| classbodydeclarations classbodydeclaration{ }
|
case $1 of
|
||||||
|
MethodDecl method -> ([method], [])
|
||||||
|
FieldDecls fields -> ([], fields)
|
||||||
|
}
|
||||||
|
-- | classbodydeclarations classbodydeclaration {
|
||||||
|
-- case ($1, $2) of
|
||||||
|
-- ((methods, fields), MethodDecl method) -> ((methods ++ [method]), fields)
|
||||||
|
-- ((methods, fields), FieldDecl field) -> (methods, (fields ++ [field]))
|
||||||
|
-- }
|
||||||
|
|
||||||
modifier : PUBLIC { }
|
modifier : PUBLIC { }
|
||||||
| PROTECTED { }
|
| PROTECTED { }
|
||||||
| PRIVATE { }
|
| PRIVATE { }
|
||||||
| STATIC { }
|
| STATIC { }
|
||||||
| ABSTRACT { }
|
| ABSTRACT { }
|
||||||
|
|
||||||
classtype : classorinterfacetype{ }
|
classtype : classorinterfacetype{ }
|
||||||
|
|
||||||
classbodydeclaration : classmemberdeclaration { }
|
classbodydeclaration : classmemberdeclaration { $1 }
|
||||||
| constructordeclaration { }
|
-- | constructordeclaration { FieldDecl $ VariableDeclaration "int" "a" Nothing } -- TODO
|
||||||
|
|
||||||
classorinterfacetype : name{ }
|
classorinterfacetype : name{ }
|
||||||
|
|
||||||
classmemberdeclaration : fielddeclaration { }
|
classmemberdeclaration : fielddeclaration { $1 }
|
||||||
| methoddeclaration { }
|
-- | methoddeclaration { }
|
||||||
|
|
||||||
constructordeclaration : constructordeclarator constructorbody { }
|
constructordeclaration : constructordeclarator constructorbody { }
|
||||||
| modifiers constructordeclarator constructorbody { }
|
| modifiers constructordeclarator constructorbody { }
|
||||||
|
|
||||||
fielddeclaration : type variabledeclarators SEMICOLON { }
|
fielddeclaration : type variabledeclarators SEMICOLON { FieldDecls $ map (convertDeclarator $1) $2 }
|
||||||
| modifiers type variabledeclarators SEMICOLON { }
|
-- | modifiers type variabledeclarators SEMICOLON {}
|
||||||
|
|
||||||
methoddeclaration : methodheader methodbody { }
|
methoddeclaration : methodheader methodbody { }
|
||||||
|
|
||||||
block : LBRACKET RBRACKET { }
|
block : LBRACKET RBRACKET { }
|
||||||
| LBRACKET blockstatements RBRACKET { }
|
| LBRACKET blockstatements RBRACKET { }
|
||||||
|
|
||||||
constructordeclarator : simplename LBRACE RBRACE { }
|
constructordeclarator : simplename LBRACE RBRACE { }
|
||||||
| simplename LBRACE formalparameterlist RBRACE { }
|
| simplename LBRACE formalparameterlist RBRACE { }
|
||||||
|
|
||||||
constructorbody : LBRACKET RBRACKET { }
|
constructorbody : LBRACKET RBRACKET { }
|
||||||
| LBRACKET explicitconstructorinvocation RBRACKET { }
|
| LBRACKET explicitconstructorinvocation RBRACKET { }
|
||||||
| LBRACKET blockstatements RBRACKET { }
|
| LBRACKET blockstatements RBRACKET { }
|
||||||
| LBRACKET explicitconstructorinvocation blockstatements RBRACKET { }
|
| LBRACKET explicitconstructorinvocation blockstatements RBRACKET { }
|
||||||
|
|
||||||
methodheader : type methoddeclarator { }
|
methodheader : type methoddeclarator { }
|
||||||
| modifiers type methoddeclarator { }
|
| modifiers type methoddeclarator { }
|
||||||
| VOID methoddeclarator { }
|
| VOID methoddeclarator { }
|
||||||
| modifiers VOID methoddeclarator { }
|
| modifiers VOID methoddeclarator { }
|
||||||
|
|
||||||
type : primitivetype { }
|
type : primitivetype { $1 }
|
||||||
| referencetype { }
|
-- | referencetype { }
|
||||||
|
|
||||||
variabledeclarators : variabledeclarator { }
|
variabledeclarators : variabledeclarator { [$1] }
|
||||||
| variabledeclarators COMMA variabledeclarator { }
|
-- | variabledeclarators COMMA variabledeclarator { $1 ++ [$3] }
|
||||||
|
|
||||||
methodbody : block { }
|
methodbody : block { }
|
||||||
| SEMICOLON { }
|
| SEMICOLON { }
|
||||||
|
|
||||||
blockstatements : blockstatement { }
|
blockstatements : blockstatement { }
|
||||||
| blockstatements blockstatement { }
|
| blockstatements blockstatement { }
|
||||||
|
|
||||||
formalparameterlist : formalparameter { }
|
formalparameterlist : formalparameter { }
|
||||||
| formalparameterlist COMMA formalparameter{ }
|
| formalparameterlist COMMA formalparameter{ }
|
||||||
|
|
||||||
explicitconstructorinvocation : THIS LBRACE RBRACE SEMICOLON { }
|
explicitconstructorinvocation : THIS LBRACE RBRACE SEMICOLON { }
|
||||||
| THIS LBRACE argumentlist RBRACE SEMICOLON { }
|
| THIS LBRACE argumentlist RBRACE SEMICOLON { }
|
||||||
|
|
||||||
classtypelist : classtype { }
|
classtypelist : classtype { }
|
||||||
| classtypelist COMMA classtype { }
|
| classtypelist COMMA classtype { }
|
||||||
|
|
||||||
methoddeclarator : IDENTIFIER LBRACE RBRACE { }
|
methoddeclarator : IDENTIFIER LBRACE RBRACE { }
|
||||||
| IDENTIFIER LBRACE formalparameterlist RBRACE { }
|
| IDENTIFIER LBRACE formalparameterlist RBRACE { }
|
||||||
|
|
||||||
primitivetype : BOOLEAN { }
|
primitivetype : BOOLEAN { "boolean" }
|
||||||
| numerictype { }
|
| numerictype { $1 }
|
||||||
|
|
||||||
referencetype : classorinterfacetype { }
|
referencetype : classorinterfacetype { }
|
||||||
|
|
||||||
|
|
||||||
variabledeclarator : variabledeclaratorid { }
|
variabledeclarator : variabledeclaratorid { Declarator $1 Nothing }
|
||||||
| variabledeclaratorid ASSIGN variableinitializer { }
|
-- | variabledeclaratorid ASSIGN variableinitializer { Declarator $1 Nothing } -- TODO
|
||||||
|
|
||||||
blockstatement : localvariabledeclarationstatement { }
|
blockstatement : localvariabledeclarationstatement { }
|
||||||
| statement { }
|
| statement { }
|
||||||
|
|
||||||
formalparameter : type variabledeclaratorid { }
|
formalparameter : type variabledeclaratorid { }
|
||||||
|
|
||||||
argumentlist : expression { }
|
argumentlist : expression { }
|
||||||
| argumentlist COMMA expression { }
|
| argumentlist COMMA expression { }
|
||||||
|
|
||||||
numerictype : integraltype { }
|
numerictype : integraltype { $1 }
|
||||||
|
|
||||||
variabledeclaratorid : IDENTIFIER { }
|
variabledeclaratorid : IDENTIFIER { $1 }
|
||||||
|
|
||||||
variableinitializer : expression { }
|
variableinitializer : expression { }
|
||||||
|
|
||||||
localvariabledeclarationstatement : localvariabledeclaration SEMICOLON { }
|
localvariabledeclarationstatement : localvariabledeclaration SEMICOLON { }
|
||||||
|
|
||||||
statement : statementwithouttrailingsubstatement{ }
|
statement : statementwithouttrailingsubstatement{ }
|
||||||
| ifthenstatement { }
|
| ifthenstatement { }
|
||||||
| ifthenelsestatement { }
|
| ifthenelsestatement { }
|
||||||
| whilestatement { }
|
| whilestatement { }
|
||||||
|
|
||||||
|
|
||||||
expression : assignmentexpression { }
|
expression : assignmentexpression { }
|
||||||
|
|
||||||
integraltype : INT { }
|
integraltype : INT { "int" }
|
||||||
| CHAR { }
|
| CHAR { "char" }
|
||||||
|
|
||||||
localvariabledeclaration : type variabledeclarators { }
|
localvariabledeclaration : type variabledeclarators { }
|
||||||
|
|
||||||
statementwithouttrailingsubstatement : block { }
|
statementwithouttrailingsubstatement : block { }
|
||||||
| emptystatement { }
|
| emptystatement { }
|
||||||
| expressionstatement { }
|
| expressionstatement { }
|
||||||
| returnstatement { }
|
| returnstatement { }
|
||||||
|
|
||||||
ifthenstatement : IF LBRACE expression RBRACE statement { }
|
ifthenstatement : IF LBRACE expression RBRACE statement { }
|
||||||
|
|
||||||
@ -216,55 +223,55 @@ ifthenelsestatement : IF LBRACE expression RBRACE statementnoshortif ELSE state
|
|||||||
whilestatement : WHILE LBRACE expression RBRACE statement { }
|
whilestatement : WHILE LBRACE expression RBRACE statement { }
|
||||||
|
|
||||||
assignmentexpression : conditionalexpression { }
|
assignmentexpression : conditionalexpression { }
|
||||||
| assignment{ }
|
| assignment{ }
|
||||||
|
|
||||||
emptystatement : SEMICOLON { }
|
emptystatement : SEMICOLON { }
|
||||||
|
|
||||||
expressionstatement : statementexpression SEMICOLON { }
|
expressionstatement : statementexpression SEMICOLON { }
|
||||||
|
|
||||||
returnstatement : RETURN SEMICOLON { }
|
returnstatement : RETURN SEMICOLON { }
|
||||||
| RETURN expression SEMICOLON { }
|
| RETURN expression SEMICOLON { }
|
||||||
|
|
||||||
statementnoshortif : statementwithouttrailingsubstatement { }
|
statementnoshortif : statementwithouttrailingsubstatement { }
|
||||||
| ifthenelsestatementnoshortif { }
|
| ifthenelsestatementnoshortif { }
|
||||||
| whilestatementnoshortif { }
|
| whilestatementnoshortif { }
|
||||||
|
|
||||||
conditionalexpression : conditionalorexpression { }
|
conditionalexpression : conditionalorexpression { }
|
||||||
| conditionalorexpression QUESMARK expression COLON conditionalexpression { }
|
| conditionalorexpression QUESMARK expression COLON conditionalexpression { }
|
||||||
|
|
||||||
assignment :lefthandside assignmentoperator assignmentexpression { }
|
assignment :lefthandside assignmentoperator assignmentexpression { }
|
||||||
|
|
||||||
|
|
||||||
statementexpression : assignment { }
|
statementexpression : assignment { }
|
||||||
| preincrementexpression { }
|
| preincrementexpression { }
|
||||||
| predecrementexpression { }
|
| predecrementexpression { }
|
||||||
| postincrementexpression { }
|
| postincrementexpression { }
|
||||||
| postdecrementexpression { }
|
| postdecrementexpression { }
|
||||||
| methodinvocation { }
|
| methodinvocation { }
|
||||||
| classinstancecreationexpression { }
|
| classinstancecreationexpression { }
|
||||||
|
|
||||||
ifthenelsestatementnoshortif :IF LBRACE expression RBRACE statementnoshortif
|
ifthenelsestatementnoshortif :IF LBRACE expression RBRACE statementnoshortif
|
||||||
ELSE statementnoshortif { }
|
ELSE statementnoshortif { }
|
||||||
|
|
||||||
whilestatementnoshortif : WHILE LBRACE expression RBRACE statementnoshortif { }
|
whilestatementnoshortif : WHILE LBRACE expression RBRACE statementnoshortif { }
|
||||||
|
|
||||||
conditionalorexpression : conditionalandexpression { }
|
conditionalorexpression : conditionalandexpression { }
|
||||||
| conditionalorexpression LOGICALOR conditionalandexpression{ }
|
| conditionalorexpression LOGICALOR conditionalandexpression{ }
|
||||||
|
|
||||||
lefthandside : name { }
|
lefthandside : name { }
|
||||||
|
|
||||||
assignmentoperator : ASSIGN{ }
|
assignmentoperator : ASSIGN{ }
|
||||||
| TIMESEQUAL { }
|
| TIMESEQUAL { }
|
||||||
| DIVIDEEQUAL { }
|
| DIVIDEEQUAL { }
|
||||||
| MODULOEQUAL { }
|
| MODULOEQUAL { }
|
||||||
| PLUSEQUAL { }
|
| PLUSEQUAL { }
|
||||||
| MINUSEQUAL { }
|
| MINUSEQUAL { }
|
||||||
| SHIFTLEFTEQUAL { }
|
| SHIFTLEFTEQUAL { }
|
||||||
| SIGNEDSHIFTRIGHTEQUAL { }
|
| SIGNEDSHIFTRIGHTEQUAL { }
|
||||||
| UNSIGNEDSHIFTRIGHTEQUAL { }
|
| UNSIGNEDSHIFTRIGHTEQUAL { }
|
||||||
| ANDEQUAL { }
|
| ANDEQUAL { }
|
||||||
| XOREQUAL { }
|
| XOREQUAL { }
|
||||||
| OREQUAL{ }
|
| OREQUAL{ }
|
||||||
|
|
||||||
preincrementexpression : INCREMENT unaryexpression { }
|
preincrementexpression : INCREMENT unaryexpression { }
|
||||||
|
|
||||||
@ -275,9 +282,9 @@ postincrementexpression : postfixexpression INCREMENT { }
|
|||||||
postdecrementexpression : postfixexpression DECREMENT { }
|
postdecrementexpression : postfixexpression DECREMENT { }
|
||||||
|
|
||||||
methodinvocation : name LBRACE RBRACE { }
|
methodinvocation : name LBRACE RBRACE { }
|
||||||
| name LBRACE argumentlist RBRACE { }
|
| name LBRACE argumentlist RBRACE { }
|
||||||
| primary DOT IDENTIFIER LBRACE RBRACE { }
|
| primary DOT IDENTIFIER LBRACE RBRACE { }
|
||||||
| primary DOT IDENTIFIER LBRACE argumentlist RBRACE { }
|
| primary DOT IDENTIFIER LBRACE argumentlist RBRACE { }
|
||||||
|
|
||||||
classinstancecreationexpression : NEW classtype LBRACE RBRACE { }
|
classinstancecreationexpression : NEW classtype LBRACE RBRACE { }
|
||||||
| NEW classtype LBRACE argumentlist RBRACE { }
|
| NEW classtype LBRACE argumentlist RBRACE { }
|
||||||
@ -286,75 +293,85 @@ conditionalandexpression : inclusiveorexpression { }
|
|||||||
|
|
||||||
fieldaccess : primary DOT IDENTIFIER { }
|
fieldaccess : primary DOT IDENTIFIER { }
|
||||||
|
|
||||||
unaryexpression : preincrementexpression { }
|
unaryexpression : preincrementexpression { }
|
||||||
| predecrementexpression { }
|
| predecrementexpression { }
|
||||||
| PLUS unaryexpression { }
|
| PLUS unaryexpression { }
|
||||||
| MINUS unaryexpression { }
|
| MINUS unaryexpression { }
|
||||||
| unaryexpressionnotplusminus { }
|
| unaryexpressionnotplusminus { }
|
||||||
|
|
||||||
postfixexpression : primary { }
|
postfixexpression : primary { }
|
||||||
| name { }
|
| name { }
|
||||||
| postincrementexpression { }
|
| postincrementexpression { }
|
||||||
| postdecrementexpression{ }
|
| postdecrementexpression{ }
|
||||||
|
|
||||||
primary : primarynonewarray { }
|
primary : primarynonewarray { }
|
||||||
|
|
||||||
inclusiveorexpression : exclusiveorexpression { }
|
inclusiveorexpression : exclusiveorexpression { }
|
||||||
| inclusiveorexpression OR exclusiveorexpression { }
|
| inclusiveorexpression OR exclusiveorexpression { }
|
||||||
|
|
||||||
primarynonewarray : literal { }
|
primarynonewarray : literal { }
|
||||||
| THIS { }
|
| THIS { }
|
||||||
| LBRACE expression RBRACE { }
|
| LBRACE expression RBRACE { }
|
||||||
| classinstancecreationexpression { }
|
| classinstancecreationexpression { }
|
||||||
| fieldaccess { }
|
| fieldaccess { }
|
||||||
| methodinvocation { }
|
| methodinvocation { }
|
||||||
|
|
||||||
unaryexpressionnotplusminus : postfixexpression { }
|
unaryexpressionnotplusminus : postfixexpression { }
|
||||||
| TILDE unaryexpression { }
|
| TILDE unaryexpression { }
|
||||||
| EXCLMARK unaryexpression { }
|
| EXCLMARK unaryexpression { }
|
||||||
| castexpression{ }
|
| castexpression{ }
|
||||||
|
|
||||||
exclusiveorexpression : andexpression { }
|
exclusiveorexpression : andexpression { }
|
||||||
| exclusiveorexpression XOR andexpression { }
|
| exclusiveorexpression XOR andexpression { }
|
||||||
|
|
||||||
literal : INTLITERAL { }
|
literal : INTLITERAL { }
|
||||||
| BOOLLITERAL { }
|
| BOOLLITERAL { }
|
||||||
| CHARLITERAL { }
|
| CHARLITERAL { }
|
||||||
| STRINGLITERAL { }
|
| JNULL { }
|
||||||
| JNULL { }
|
|
||||||
|
|
||||||
castexpression : LBRACE primitivetype RBRACE unaryexpression { }
|
castexpression : LBRACE primitivetype RBRACE unaryexpression { }
|
||||||
| LBRACE expression RBRACE unaryexpressionnotplusminus{ }
|
| LBRACE expression RBRACE unaryexpressionnotplusminus{ }
|
||||||
|
|
||||||
andexpression : equalityexpression { }
|
andexpression : equalityexpression { }
|
||||||
| andexpression AND equalityexpression { }
|
| andexpression AND equalityexpression { }
|
||||||
|
|
||||||
equalityexpression : relationalexpression { }
|
equalityexpression : relationalexpression { }
|
||||||
| equalityexpression EQUAL relationalexpression { }
|
| equalityexpression EQUAL relationalexpression { }
|
||||||
| equalityexpression NOTEQUAL relationalexpression { }
|
| equalityexpression NOTEQUAL relationalexpression { }
|
||||||
|
|
||||||
relationalexpression : shiftexpression { }
|
relationalexpression : shiftexpression { }
|
||||||
| relationalexpression LESS shiftexpression { }
|
| relationalexpression LESS shiftexpression { }
|
||||||
| relationalexpression GREATER shiftexpression { }
|
| relationalexpression GREATER shiftexpression { }
|
||||||
| relationalexpression LESSEQUAL shiftexpression { }
|
| relationalexpression LESSEQUAL shiftexpression { }
|
||||||
| relationalexpression GREATEREQUAL shiftexpression { }
|
| relationalexpression GREATEREQUAL shiftexpression { }
|
||||||
| relationalexpression INSTANCEOF referencetype { }
|
| relationalexpression INSTANCEOF referencetype { }
|
||||||
|
|
||||||
shiftexpression : additiveexpression { }
|
shiftexpression : additiveexpression { }
|
||||||
|
|
||||||
additiveexpression : multiplicativeexpression { }
|
additiveexpression : multiplicativeexpression { }
|
||||||
| additiveexpression PLUS multiplicativeexpression { }
|
| additiveexpression PLUS multiplicativeexpression { }
|
||||||
| additiveexpression MINUS multiplicativeexpression { }
|
| additiveexpression MINUS multiplicativeexpression { }
|
||||||
|
|
||||||
multiplicativeexpression : unaryexpression { }
|
multiplicativeexpression : unaryexpression { }
|
||||||
| multiplicativeexpression MUL unaryexpression { }
|
| multiplicativeexpression MUL unaryexpression { }
|
||||||
| multiplicativeexpression DIV unaryexpression { }
|
| multiplicativeexpression DIV unaryexpression { }
|
||||||
| multiplicativeexpression MOD unaryexpression { }
|
| multiplicativeexpression MOD unaryexpression { }
|
||||||
|
|
||||||
|
|
||||||
{
|
{
|
||||||
|
|
||||||
|
data MethodOrFieldDeclaration = MethodDecl MethodDeclaration
|
||||||
|
| FieldDecls [VariableDeclaration]
|
||||||
|
|
||||||
|
data Declarator = Declarator Identifier (Maybe Expression)
|
||||||
|
|
||||||
|
-- convertDeclaratorList :: [DataType] -> MethodOrFieldDeclaration
|
||||||
|
-- convertDeclaratorList = FieldDecls $ map
|
||||||
|
|
||||||
|
convertDeclarator :: DataType -> Declarator -> VariableDeclaration
|
||||||
|
convertDeclarator dataType (Declarator id assigment) = VariableDeclaration dataType id assigment
|
||||||
|
|
||||||
parseError :: [Token] -> a
|
parseError :: [Token] -> a
|
||||||
parseError _ = error "Parse error"
|
parseError msg = error ("Parse error: " ++ show msg)
|
||||||
|
|
||||||
}
|
}
|
||||||
|
@ -1,5 +1,6 @@
|
|||||||
{
|
{
|
||||||
module Parser.Lexer(Token(..), alexScanTokens) where
|
module Parser.Lexer(Token(..), alexScanTokens) where
|
||||||
|
import Text.Read
|
||||||
}
|
}
|
||||||
|
|
||||||
%wrapper "basic"
|
%wrapper "basic"
|
||||||
@ -7,18 +8,221 @@
|
|||||||
$digit = 0-9
|
$digit = 0-9
|
||||||
$alpha = [a-zA-Z]
|
$alpha = [a-zA-Z]
|
||||||
$alphanum = [a-zA-Z0-9]
|
$alphanum = [a-zA-Z0-9]
|
||||||
|
$JavaLetter = [A-Za-z\_\$]
|
||||||
|
$JavaLetterOrDigit = [A-Za-z\_\$0-9]
|
||||||
|
|
||||||
tokens :-
|
tokens :-
|
||||||
$white ;
|
$white ;
|
||||||
"/*"(.|\n)*"*/" { \s -> Comment s }
|
"/*"(.|\n)*"*/" ;
|
||||||
"//".* {\s -> Comment s}
|
"//".* ;
|
||||||
|
-- keywords
|
||||||
|
"abstract" { \_ -> ABSTRACT }
|
||||||
|
"assert" { \_ -> BOOLEAN }
|
||||||
|
"boolean" { \_ -> BOOLEAN}
|
||||||
|
"break" { \_ -> BREAK}
|
||||||
|
"byte" { \_ -> BYTE}
|
||||||
|
"case" { \_ -> CASE}
|
||||||
|
"catch" { \_ -> CATCH}
|
||||||
|
"char" { \_ -> CHAR}
|
||||||
|
"class" { \_ -> CLASS}
|
||||||
|
"const" { \_ -> CONST}
|
||||||
|
"continue" { \_ -> CONTINUE}
|
||||||
|
"default" { \_ -> DEFAULT}
|
||||||
|
"do" { \_ -> DO}
|
||||||
|
"double" { \_ -> DOUBLE}
|
||||||
|
("else"|"ifn't") { \_ -> ELSE}
|
||||||
|
"enum" { \_ -> ENUM}
|
||||||
|
"extends" { \_ -> EXTENDS}
|
||||||
|
"final" { \_ -> FINAL}
|
||||||
|
"finally" { \_ -> FINALLY}
|
||||||
|
"float" { \_ -> FLOAT}
|
||||||
|
"for" { \_ -> FOR}
|
||||||
|
"if" { \_ -> IF}
|
||||||
|
"goto" { \_ -> GOTO}
|
||||||
|
"implements" { \_ -> IMPLEMENTS}
|
||||||
|
"import" { \_ -> IMPORT}
|
||||||
|
"instanceof" { \_ -> INSTANCEOF}
|
||||||
|
"int" { \_ -> INT}
|
||||||
|
"long" { \_ -> LONG}
|
||||||
|
"native" { \_ -> NATIVE}
|
||||||
|
"new" { \_ -> NEW}
|
||||||
|
"package" { \_ -> PACKAGE}
|
||||||
|
"private" { \_ -> PRIVATE}
|
||||||
|
"protected" { \_ -> PROTECTED}
|
||||||
|
"public" { \_ -> PUBLIC}
|
||||||
|
"return" { \_ -> RETURN}
|
||||||
|
"short" { \_ -> SHORT}
|
||||||
|
"static" { \_ -> STATIC}
|
||||||
|
"strictfp" { \_ -> STRICTFP}
|
||||||
|
"super" { \_ -> SUPER}
|
||||||
|
"switch" { \_ -> SWITCH}
|
||||||
|
"synchronized" { \_ -> SYNCHRONIZED}
|
||||||
|
"this" { \_ -> THIS}
|
||||||
|
"throw" { \_ -> THROW}
|
||||||
|
"throws" { \_ -> THROWS}
|
||||||
|
"transient" { \_ -> TRANSIENT}
|
||||||
|
"try" { \_ -> TRY}
|
||||||
|
"void" { \_ -> VOID}
|
||||||
|
"volatile" { \_ -> VOLATILE}
|
||||||
|
"while" { \_ -> WHILE}
|
||||||
|
-- Literals
|
||||||
|
"true" { \_ -> BOOLLITERAL True }
|
||||||
|
"false" { \_ -> BOOLLITERAL False }
|
||||||
|
"null" { \_ -> NULLLITERAL }
|
||||||
|
-- end keywords
|
||||||
|
$JavaLetter$JavaLetterOrDigit* { \s -> IDENTIFIER s }
|
||||||
|
-- Literals
|
||||||
|
[1-9]([0-9\_]*[0-9])* { \s -> case readMaybe $ filter ((/=) '_') s of Just a -> INTEGERLITERAL a; Nothing -> error ("failed to parse INTLITERAL " ++ s) }
|
||||||
|
"'"."'" { \s -> case (s) of _ : c : _ -> CHARLITERAL c; _ -> error ("failed to parse CHARLITERAL " ++ s) }
|
||||||
|
-- separators
|
||||||
|
"(" { \_ -> LBRACE }
|
||||||
|
")" { \_ -> RBRACE }
|
||||||
|
"{" { \_ -> LBRACKET }
|
||||||
|
"}" { \_ -> RBRACKET }
|
||||||
|
";" { \_ -> SEMICOLON }
|
||||||
|
"," { \_ -> COMMA}
|
||||||
|
"." { \_ -> DOT }
|
||||||
|
-- operators
|
||||||
|
"=" { \_ -> ASSIGN }
|
||||||
|
"==" { \_ -> EQUAL }
|
||||||
|
"+" { \_ -> PLUS }
|
||||||
|
"+=" { \_ -> PLUSEQUAL }
|
||||||
|
">" { \_ -> GREATER }
|
||||||
|
">=" { \_ -> GREATEREQUAL }
|
||||||
|
"-" { \_ -> MINUS }
|
||||||
|
"-=" { \_ -> MINUSEQUAL }
|
||||||
|
"<" { \_ -> LESS }
|
||||||
|
"<=" { \_ -> LESSEQUAL }
|
||||||
|
"*" { \_ -> TIMES }
|
||||||
|
"*=" { \_ -> TIMESEQUAL }
|
||||||
|
"!" { \_ -> NOT }
|
||||||
|
"!=" { \_ -> NOTEQUAL }
|
||||||
|
"/" { \_ -> DIV }
|
||||||
|
"/=" { \_ -> DIVEQUAL }
|
||||||
|
"~" { \_ -> BITWISENOT }
|
||||||
|
"&&" { \_ -> AND }
|
||||||
|
"&" { \_ -> BITWISEAND }
|
||||||
|
"&=" { \_ -> ANDEQUAL }
|
||||||
|
"?" { \_ -> QUESTIONMARK }
|
||||||
|
"||" { \_ -> OR }
|
||||||
|
"|" { \_ -> BITWISEOR }
|
||||||
|
"|=" { \_ -> OREQUAL }
|
||||||
|
":" { \_ -> COLON }
|
||||||
|
"++" { \_ -> INCREMENT }
|
||||||
|
"^" { \_ -> XOR }
|
||||||
|
"^=" { \_ -> XOREQUAL }
|
||||||
|
"--" { \_ -> DECREMENT }
|
||||||
|
"%" { \_ -> MODULO }
|
||||||
|
"%=" { \_ -> MODULOEQUAL }
|
||||||
|
"<<" { \_ -> SHIFTLEFT }
|
||||||
|
"<<=" { \_ -> SHIFTLEFTEQUAL }
|
||||||
|
">>" { \_ -> SHIFTRIGHT }
|
||||||
|
">>=" { \_ -> SHIFTRIGHTEQUAL }
|
||||||
|
">>>" { \_ -> UNSIGNEDSHIFTRIGHT }
|
||||||
|
">>>=" { \_ -> UNSIGNEDSHIFTRIGHTEQUAL }
|
||||||
|
|
||||||
|
|
||||||
{
|
{
|
||||||
data Token
|
data Token
|
||||||
= Comment String
|
= ABSTRACT
|
||||||
| Different
|
| ASSERT
|
||||||
|
| BOOLEAN
|
||||||
|
| BREAK
|
||||||
|
| BYTE
|
||||||
|
| CASE
|
||||||
|
| CATCH
|
||||||
|
| CHAR
|
||||||
|
| CLASS
|
||||||
|
| CONST
|
||||||
|
| CONTINUE
|
||||||
|
| DEFAULT
|
||||||
|
| DO
|
||||||
|
| DOUBLE
|
||||||
|
| ELSE
|
||||||
|
| ENUM
|
||||||
|
| EXTENDS
|
||||||
|
| FINAL
|
||||||
|
| FINALLY
|
||||||
|
| FLOAT
|
||||||
|
| FOR
|
||||||
|
| IF
|
||||||
|
| GOTO
|
||||||
|
| IMPLEMENTS
|
||||||
|
| IMPORT
|
||||||
|
| INSTANCEOF
|
||||||
|
| INT
|
||||||
|
| INTERFACE
|
||||||
|
| LONG
|
||||||
|
| NATIVE
|
||||||
|
| NEW
|
||||||
|
| PACKAGE
|
||||||
|
| PRIVATE
|
||||||
|
| PROTECTED
|
||||||
|
| PUBLIC
|
||||||
|
| RETURN
|
||||||
|
| SHORT
|
||||||
|
| STATIC
|
||||||
|
| STRICTFP
|
||||||
|
| SUPER
|
||||||
|
| SWITCH
|
||||||
|
| SYNCHRONIZED
|
||||||
|
| THIS
|
||||||
|
| THROW
|
||||||
|
| THROWS
|
||||||
|
| TRANSIENT
|
||||||
|
| TRY
|
||||||
|
| VOID
|
||||||
|
| VOLATILE
|
||||||
|
| WHILE
|
||||||
|
| IDENTIFIER String
|
||||||
|
| INTEGERLITERAL Int
|
||||||
|
| CHARLITERAL Char
|
||||||
|
| BOOLLITERAL Bool
|
||||||
|
| NULLLITERAL
|
||||||
|
| LBRACE
|
||||||
|
| RBRACE
|
||||||
|
| LBRACKET
|
||||||
|
| RBRACKET
|
||||||
|
| SEMICOLON
|
||||||
|
| COMMA
|
||||||
|
| DOT
|
||||||
|
| ASSIGN
|
||||||
|
| EQUAL
|
||||||
|
| PLUS
|
||||||
|
| PLUSEQUAL
|
||||||
|
| GREATER
|
||||||
|
| GREATEREQUAL
|
||||||
|
| MINUS
|
||||||
|
| MINUSEQUAL
|
||||||
|
| LESS
|
||||||
|
| LESSEQUAL
|
||||||
|
| TIMES
|
||||||
|
| TIMESEQUAL
|
||||||
|
| NOT
|
||||||
|
| NOTEQUAL
|
||||||
|
| DIV
|
||||||
|
| DIVEQUAL
|
||||||
|
| BITWISENOT
|
||||||
|
| AND
|
||||||
|
| BITWISEAND
|
||||||
|
| ANDEQUAL
|
||||||
|
| QUESTIONMARK
|
||||||
|
| OR
|
||||||
|
| BITWISEOR
|
||||||
|
| OREQUAL
|
||||||
|
| COLON
|
||||||
|
| INCREMENT
|
||||||
|
| XOR
|
||||||
|
| XOREQUAL
|
||||||
|
| DECREMENT
|
||||||
|
| MODULO
|
||||||
|
| MODULOEQUAL
|
||||||
|
| SHIFTLEFT
|
||||||
|
| SHIFTLEFTEQUAL
|
||||||
|
| SHIFTRIGHT
|
||||||
|
| SHIFTRIGHTEQUAL
|
||||||
|
| UNSIGNEDSHIFTRIGHT
|
||||||
|
| UNSIGNEDSHIFTRIGHTEQUAL
|
||||||
deriving(Eq,Show)
|
deriving(Eq,Show)
|
||||||
|
|
||||||
}
|
}
|
334
src/Typecheck.hs
Normal file
334
src/Typecheck.hs
Normal file
@ -0,0 +1,334 @@
|
|||||||
|
module Typecheck where
|
||||||
|
import Data.List (find)
|
||||||
|
import Data.Maybe
|
||||||
|
import Ast
|
||||||
|
|
||||||
|
typeCheckCompilationUnit :: CompilationUnit -> CompilationUnit
|
||||||
|
typeCheckCompilationUnit classes = map (`typeCheckClass` classes) classes
|
||||||
|
|
||||||
|
typeCheckClass :: Class -> [Class] -> Class
|
||||||
|
typeCheckClass (Class className methods fields) classes =
|
||||||
|
let
|
||||||
|
-- Create a symbol table from class fields and method entries
|
||||||
|
classFields = [(id, dt) | VariableDeclaration dt id _ <- fields]
|
||||||
|
methodEntries = [(methodName, className) | MethodDeclaration _ methodName _ _ <- methods]
|
||||||
|
initalSymTab = ("this", className) : classFields ++ methodEntries
|
||||||
|
checkedMethods = map (\method -> typeCheckMethodDeclaration method initalSymTab classes) methods
|
||||||
|
in Class className checkedMethods fields
|
||||||
|
|
||||||
|
typeCheckMethodDeclaration :: MethodDeclaration -> [(Identifier, DataType)] -> [Class] -> MethodDeclaration
|
||||||
|
typeCheckMethodDeclaration (MethodDeclaration retType name params body) classFields classes =
|
||||||
|
let
|
||||||
|
-- Combine class fields with method parameters to form the initial symbol table for the method
|
||||||
|
methodParams = [(identifier, dataType) | ParameterDeclaration dataType identifier <- params]
|
||||||
|
initialSymtab = classFields ++ methodParams
|
||||||
|
checkedBody = typeCheckStatement body initialSymtab classes
|
||||||
|
bodyType = getTypeFromStmt checkedBody
|
||||||
|
-- Check if the type of the body matches the declared return type
|
||||||
|
in if bodyType == retType || (bodyType == "void" && retType == "void")
|
||||||
|
then MethodDeclaration retType name params checkedBody
|
||||||
|
else error $ "Return type mismatch in method " ++ name ++ ": expected " ++ retType ++ ", found " ++ bodyType
|
||||||
|
|
||||||
|
-- ********************************** Type Checking: Expressions **********************************
|
||||||
|
|
||||||
|
typeCheckExpression :: Expression -> [(Identifier, DataType)] -> [Class] -> Expression
|
||||||
|
typeCheckExpression (IntegerLiteral i) _ _ = TypedExpression "int" (IntegerLiteral i)
|
||||||
|
typeCheckExpression (CharacterLiteral c) _ _ = TypedExpression "char" (CharacterLiteral c)
|
||||||
|
typeCheckExpression (BooleanLiteral b) _ _ = TypedExpression "boolean" (BooleanLiteral b)
|
||||||
|
typeCheckExpression NullLiteral _ _ = TypedExpression "null" NullLiteral
|
||||||
|
typeCheckExpression (Reference id) symtab classes =
|
||||||
|
let type' = lookupType id symtab
|
||||||
|
in TypedExpression type' (Reference id)
|
||||||
|
typeCheckExpression (BinaryOperation op expr1 expr2) symtab classes =
|
||||||
|
let expr1' = typeCheckExpression expr1 symtab classes
|
||||||
|
expr2' = typeCheckExpression expr2 symtab classes
|
||||||
|
type1 = getTypeFromExpr expr1'
|
||||||
|
type2 = getTypeFromExpr expr2'
|
||||||
|
in case op of
|
||||||
|
Addition ->
|
||||||
|
if type1 == "int" && type2 == "int"
|
||||||
|
then
|
||||||
|
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
||||||
|
else
|
||||||
|
error "Addition operation requires two operands of type int"
|
||||||
|
Subtraction ->
|
||||||
|
if type1 == "int" && type2 == "int"
|
||||||
|
then
|
||||||
|
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
||||||
|
else
|
||||||
|
error "Subtraction operation requires two operands of type int"
|
||||||
|
Multiplication ->
|
||||||
|
if type1 == "int" && type2 == "int"
|
||||||
|
then
|
||||||
|
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
||||||
|
else
|
||||||
|
error "Multiplication operation requires two operands of type int"
|
||||||
|
Division ->
|
||||||
|
if type1 == "int" && type2 == "int"
|
||||||
|
then
|
||||||
|
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
||||||
|
else
|
||||||
|
error "Division operation requires two operands of type int"
|
||||||
|
BitwiseAnd ->
|
||||||
|
if type1 == "int" && type2 == "int"
|
||||||
|
then
|
||||||
|
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
||||||
|
else
|
||||||
|
error "Bitwise AND operation requires two operands of type int"
|
||||||
|
BitwiseOr ->
|
||||||
|
if type1 == "int" && type2 == "int"
|
||||||
|
then
|
||||||
|
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
||||||
|
else
|
||||||
|
error "Bitwise OR operation requires two operands of type int"
|
||||||
|
BitwiseXor ->
|
||||||
|
if type1 == "int" && type2 == "int"
|
||||||
|
then
|
||||||
|
TypedExpression "int" (BinaryOperation op expr1' expr2')
|
||||||
|
else
|
||||||
|
error "Bitwise XOR operation requires two operands of type int"
|
||||||
|
CompareLessThan ->
|
||||||
|
if type1 == "int" && type2 == "int"
|
||||||
|
then
|
||||||
|
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
||||||
|
else
|
||||||
|
error "Less than operation requires two operands of type int"
|
||||||
|
CompareLessOrEqual ->
|
||||||
|
if type1 == "int" && type2 == "int"
|
||||||
|
then
|
||||||
|
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
||||||
|
else
|
||||||
|
error "Less than or equal operation requires two operands of type int"
|
||||||
|
CompareGreaterThan ->
|
||||||
|
if type1 == "int" && type2 == "int"
|
||||||
|
then
|
||||||
|
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
||||||
|
else
|
||||||
|
error "Greater than operation requires two operands of type int"
|
||||||
|
CompareGreaterOrEqual ->
|
||||||
|
if type1 == "int" && type2 == "int"
|
||||||
|
then
|
||||||
|
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
||||||
|
else
|
||||||
|
error "Greater than or equal operation requires two operands of type int"
|
||||||
|
CompareEqual ->
|
||||||
|
if type1 == type2
|
||||||
|
then
|
||||||
|
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
||||||
|
else
|
||||||
|
error "Equality operation requires two operands of the same type"
|
||||||
|
CompareNotEqual ->
|
||||||
|
if type1 == type2
|
||||||
|
then
|
||||||
|
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
||||||
|
else
|
||||||
|
error "Inequality operation requires two operands of the same type"
|
||||||
|
And ->
|
||||||
|
if type1 == "boolean" && type2 == "boolean"
|
||||||
|
then
|
||||||
|
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
||||||
|
else
|
||||||
|
error "Logical AND operation requires two operands of type boolean"
|
||||||
|
Or ->
|
||||||
|
if type1 == "boolean" && type2 == "boolean"
|
||||||
|
then
|
||||||
|
TypedExpression "boolean" (BinaryOperation op expr1' expr2')
|
||||||
|
else
|
||||||
|
error "Logical OR operation requires two operands of type boolean"
|
||||||
|
NameResolution ->
|
||||||
|
case (expr1', expr2) of
|
||||||
|
(TypedExpression t1 (Reference obj), Reference member) ->
|
||||||
|
let objectType = lookupType obj symtab
|
||||||
|
classDetails = find (\(Class className _ _) -> className == objectType) classes
|
||||||
|
in case classDetails of
|
||||||
|
Just (Class _ _ fields) ->
|
||||||
|
let fieldTypes = [dt | VariableDeclaration dt id _ <- fields, id == member]
|
||||||
|
in case fieldTypes of
|
||||||
|
[resolvedType] -> TypedExpression resolvedType (BinaryOperation NameResolution expr1' (TypedExpression resolvedType expr2))
|
||||||
|
[] -> error $ "Field '" ++ member ++ "' not found in class '" ++ objectType ++ "'"
|
||||||
|
_ -> error $ "Ambiguous reference to field '" ++ member ++ "' in class '" ++ objectType ++ "'"
|
||||||
|
Nothing -> error $ "Object '" ++ obj ++ "' does not correspond to a known class"
|
||||||
|
_ -> error "Name resolution requires object reference and field name"
|
||||||
|
|
||||||
|
typeCheckExpression (UnaryOperation op expr) symtab classes =
|
||||||
|
let expr' = typeCheckExpression expr symtab classes
|
||||||
|
type' = getTypeFromExpr expr'
|
||||||
|
in case op of
|
||||||
|
Not ->
|
||||||
|
if type' == "boolean"
|
||||||
|
then
|
||||||
|
TypedExpression "boolean" (UnaryOperation op expr')
|
||||||
|
else
|
||||||
|
error "Logical NOT operation requires an operand of type boolean"
|
||||||
|
Minus ->
|
||||||
|
if type' == "int"
|
||||||
|
then
|
||||||
|
TypedExpression "int" (UnaryOperation op expr')
|
||||||
|
else
|
||||||
|
error "Unary minus operation requires an operand of type int"
|
||||||
|
|
||||||
|
typeCheckExpression (StatementExpressionExpression stmtExpr) symtab classes =
|
||||||
|
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
|
||||||
|
in TypedExpression (getTypeFromStmtExpr stmtExpr') (StatementExpressionExpression stmtExpr')
|
||||||
|
|
||||||
|
-- ********************************** Type Checking: StatementExpressions **********************************
|
||||||
|
|
||||||
|
typeCheckStatementExpression :: StatementExpression -> [(Identifier, DataType)] -> [Class] -> StatementExpression
|
||||||
|
typeCheckStatementExpression (Assignment id expr) symtab classes =
|
||||||
|
let expr' = typeCheckExpression expr symtab classes
|
||||||
|
type' = getTypeFromExpr expr'
|
||||||
|
type'' = lookupType id symtab
|
||||||
|
in if type' == type''
|
||||||
|
then
|
||||||
|
TypedStatementExpression type' (Assignment id expr')
|
||||||
|
else
|
||||||
|
error "Assignment type mismatch"
|
||||||
|
|
||||||
|
typeCheckStatementExpression (ConstructorCall className args) symtab classes =
|
||||||
|
case find (\(Class name _ _) -> name == className) classes of
|
||||||
|
Nothing -> error $ "Class '" ++ className ++ "' not found."
|
||||||
|
Just (Class _ methods fields) ->
|
||||||
|
-- Constructor needs the same name as the class
|
||||||
|
case find (\(MethodDeclaration retType name params _) -> name == className && retType == className) methods of
|
||||||
|
Nothing -> error $ "No valid constructor found for class '" ++ className ++ "'."
|
||||||
|
Just (MethodDeclaration _ _ params _) ->
|
||||||
|
let
|
||||||
|
args' = map (\arg -> typeCheckExpression arg symtab classes) args
|
||||||
|
-- Extract expected parameter types from the constructor's parameters
|
||||||
|
expectedTypes = [dataType | ParameterDeclaration dataType _ <- params]
|
||||||
|
argTypes = map getTypeFromExpr args'
|
||||||
|
-- Check if the types of the provided arguments match the expected types
|
||||||
|
typeMatches = zipWith (\expected actual -> if expected == actual then Nothing else Just (expected, actual)) expectedTypes argTypes
|
||||||
|
mismatchErrors = map (\(exp, act) -> "Expected type '" ++ exp ++ "', found '" ++ act ++ "'.") (catMaybes typeMatches)
|
||||||
|
in
|
||||||
|
if length args /= length params then
|
||||||
|
error $ "Constructor for class '" ++ className ++ "' expects " ++ show (length params) ++ " arguments, but got " ++ show (length args) ++ "."
|
||||||
|
else if not (null mismatchErrors) then
|
||||||
|
error $ unlines $ ("Type mismatch in constructor arguments for class '" ++ className ++ "':") : mismatchErrors
|
||||||
|
else
|
||||||
|
TypedStatementExpression className (ConstructorCall className args')
|
||||||
|
|
||||||
|
typeCheckStatementExpression (MethodCall expr methodName args) symtab classes =
|
||||||
|
let objExprTyped = typeCheckExpression expr symtab classes
|
||||||
|
in case objExprTyped of
|
||||||
|
TypedExpression objType _ ->
|
||||||
|
case find (\(Class className _ _) -> className == objType) classes of
|
||||||
|
Just (Class _ methods _) ->
|
||||||
|
case find (\(MethodDeclaration retType name params _) -> name == methodName) methods of
|
||||||
|
Just (MethodDeclaration retType _ params _) ->
|
||||||
|
let args' = map (\arg -> typeCheckExpression arg symtab classes) args
|
||||||
|
expectedTypes = [dataType | ParameterDeclaration dataType _ <- params]
|
||||||
|
argTypes = map getTypeFromExpr args'
|
||||||
|
typeMatches = zipWith (\expType argType -> (expType == argType, expType, argType)) expectedTypes argTypes
|
||||||
|
mismatches = filter (not . fst3) typeMatches
|
||||||
|
where fst3 (a, _, _) = a
|
||||||
|
in
|
||||||
|
if null mismatches && length args == length params then
|
||||||
|
TypedStatementExpression retType (MethodCall objExprTyped methodName args')
|
||||||
|
else if not (null mismatches) then
|
||||||
|
error $ unlines $ ("Argument type mismatches for method '" ++ methodName ++ "':")
|
||||||
|
: [ "Expected: " ++ expType ++ ", Found: " ++ argType | (_, expType, argType) <- mismatches ]
|
||||||
|
else
|
||||||
|
error $ "Incorrect number of arguments for method '" ++ methodName ++ "'. Expected " ++ show (length expectedTypes) ++ ", found " ++ show (length args) ++ "."
|
||||||
|
Nothing -> error $ "Method '" ++ methodName ++ "' not found in class '" ++ objType ++ "'."
|
||||||
|
Nothing -> error $ "Class for object type '" ++ objType ++ "' not found."
|
||||||
|
_ -> error "Invalid object type for method call. Object must have a class type."
|
||||||
|
|
||||||
|
-- ********************************** Type Checking: Statements **********************************
|
||||||
|
|
||||||
|
typeCheckStatement :: Statement -> [(Identifier, DataType)] -> [Class] -> Statement
|
||||||
|
typeCheckStatement (If cond thenStmt elseStmt) symtab classes =
|
||||||
|
let cond' = typeCheckExpression cond symtab classes
|
||||||
|
thenStmt' = typeCheckStatement thenStmt symtab classes
|
||||||
|
elseStmt' = case elseStmt of
|
||||||
|
Just stmt -> Just (typeCheckStatement stmt symtab classes)
|
||||||
|
Nothing -> Nothing
|
||||||
|
in if getTypeFromExpr cond' == "boolean"
|
||||||
|
then
|
||||||
|
TypedStatement (getTypeFromStmt thenStmt') (If cond' thenStmt' elseStmt')
|
||||||
|
else
|
||||||
|
error "If condition must be of type boolean"
|
||||||
|
|
||||||
|
typeCheckStatement (LocalVariableDeclaration (VariableDeclaration dataType identifier maybeExpr)) symtab classes =
|
||||||
|
-- Check for redefinition in the current scope
|
||||||
|
if any ((== identifier) . snd) symtab
|
||||||
|
then error $ "Variable '" ++ identifier ++ "' is redefined in the same scope"
|
||||||
|
else
|
||||||
|
-- If there's an initializer expression, type check it
|
||||||
|
let checkedExpr = fmap (\expr -> typeCheckExpression expr symtab classes) maybeExpr
|
||||||
|
exprType = fmap getTypeFromExpr checkedExpr
|
||||||
|
in case exprType of
|
||||||
|
Just t | t /= dataType -> error $ "Type mismatch in declaration of '" ++ identifier ++ "': expected " ++ dataType ++ ", found " ++ t
|
||||||
|
_ -> TypedStatement dataType (LocalVariableDeclaration (VariableDeclaration dataType identifier checkedExpr))
|
||||||
|
|
||||||
|
typeCheckStatement (While cond stmt) symtab classes =
|
||||||
|
let cond' = typeCheckExpression cond symtab classes
|
||||||
|
stmt' = typeCheckStatement stmt symtab classes
|
||||||
|
in if getTypeFromExpr cond' == "boolean"
|
||||||
|
then
|
||||||
|
TypedStatement (getTypeFromStmt stmt') (While cond' stmt')
|
||||||
|
else
|
||||||
|
error "While condition must be of type boolean"
|
||||||
|
|
||||||
|
typeCheckStatement (Block statements) symtab classes =
|
||||||
|
let
|
||||||
|
processStatements (accSts, currentSymtab, types) stmt =
|
||||||
|
let
|
||||||
|
checkedStmt = typeCheckStatement stmt currentSymtab classes
|
||||||
|
stmtType = getTypeFromStmt checkedStmt
|
||||||
|
in case stmt of
|
||||||
|
LocalVariableDeclaration (VariableDeclaration dataType identifier maybeExpr) ->
|
||||||
|
let
|
||||||
|
checkedExpr = fmap (\expr -> typeCheckExpression expr currentSymtab classes) maybeExpr
|
||||||
|
newSymtab = (identifier, dataType) : currentSymtab
|
||||||
|
in (accSts ++ [checkedStmt], newSymtab, types)
|
||||||
|
|
||||||
|
If {} -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
||||||
|
While _ _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
||||||
|
Return _ -> (accSts ++ [checkedStmt], currentSymtab, if stmtType /= "void" then types ++ [stmtType] else types)
|
||||||
|
_ -> (accSts ++ [checkedStmt], currentSymtab, types)
|
||||||
|
|
||||||
|
-- Initial accumulator: empty statements list, initial symbol table, empty types list
|
||||||
|
(checkedStatements, finalSymtab, collectedTypes) = foldl processStatements ([], symtab, []) statements
|
||||||
|
|
||||||
|
-- Determine the block's type: unify all collected types, default to "Void" if none
|
||||||
|
blockType = if null collectedTypes then "void" else foldl1 unifyReturnTypes collectedTypes
|
||||||
|
|
||||||
|
in TypedStatement blockType (Block checkedStatements)
|
||||||
|
|
||||||
|
typeCheckStatement (Return expr) symtab classes =
|
||||||
|
let expr' = case expr of
|
||||||
|
Just e -> Just (typeCheckExpression e symtab classes)
|
||||||
|
Nothing -> Nothing
|
||||||
|
in case expr' of
|
||||||
|
Just e' -> TypedStatement (getTypeFromExpr e') (Return (Just e'))
|
||||||
|
Nothing -> TypedStatement "Void" (Return Nothing)
|
||||||
|
|
||||||
|
typeCheckStatement (StatementExpressionStatement stmtExpr) symtab classes =
|
||||||
|
let stmtExpr' = typeCheckStatementExpression stmtExpr symtab classes
|
||||||
|
in TypedStatement (getTypeFromStmtExpr stmtExpr') (StatementExpressionStatement stmtExpr')
|
||||||
|
|
||||||
|
-- ********************************** Type Checking: Helpers **********************************
|
||||||
|
|
||||||
|
getTypeFromExpr :: Expression -> DataType
|
||||||
|
getTypeFromExpr (TypedExpression t _) = t
|
||||||
|
getTypeFromExpr _ = error "Untyped expression found where typed was expected"
|
||||||
|
|
||||||
|
getTypeFromStmt :: Statement -> DataType
|
||||||
|
getTypeFromStmt (TypedStatement t _) = t
|
||||||
|
getTypeFromStmt _ = error "Untyped statement found where typed was expected"
|
||||||
|
|
||||||
|
getTypeFromStmtExpr :: StatementExpression -> DataType
|
||||||
|
getTypeFromStmtExpr (TypedStatementExpression t _) = t
|
||||||
|
getTypeFromStmtExpr _ = error "Untyped statement expression found where typed was expected"
|
||||||
|
|
||||||
|
unifyReturnTypes :: DataType -> DataType -> DataType
|
||||||
|
unifyReturnTypes dt1 dt2
|
||||||
|
| dt1 == dt2 = dt1
|
||||||
|
| otherwise = "Object"
|
||||||
|
|
||||||
|
lookupType :: Identifier -> [(Identifier, DataType)] -> DataType
|
||||||
|
lookupType id symtab =
|
||||||
|
case lookup id symtab of
|
||||||
|
Just t -> t
|
||||||
|
Nothing -> error ("Identifier " ++ id ++ " not found in symbol table")
|
Loading…
Reference in New Issue
Block a user