1-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>2--3-- SPDX-License-Identifier: GPL-3.0-only45module Parser where67import qualified Data.Map as Map8import Language.QBE.Parser (dataDef, funcDef, typeDef)9import Language.QBE.Types10import Test.Tasty11import Test.Tasty.HUnit12import qualified Text.ParserCombinators.Parsec as P1314typeTests :: TestTree15typeTests =16 testGroup17 "Aggregate Type Definition"18 [ testCase "Opaque type with alignment" $19 let v = TypeDef (UserIdent "opaque") (Just AlignLongLong) (AOpaque 32)20 in parse "type :opaque = align 16 { 32 }" @?= Right v,21 testCase "Regular empty type" $22 let v = TypeDef (UserIdent "empty") Nothing (ARegular [])23 in parse "type :empty = {}" @?= Right v,24 testCase "Regular type with multiple fields" $25 let f = [(SExtType (Base Single), Nothing), (SExtType (Base Single), Nothing)]26 v = TypeDef (UserIdent "twofloats") Nothing (ARegular f)27 in parse "type :twofloats = { s, s }" @?= Right v,28 testCase "Regular type with trailing whitespaces" $29 let f = [(SExtType Byte, Nothing), (SExtType (Base Word), Just 100)]30 v = TypeDef (UserIdent "abyteandmanywords") Nothing (ARegular f)31 in parse "type :abyteandmanywords = { b, w 100 }" @?= Right v,32 testCase "Union type with multiple fields" $33 let f = [[(SExtType Byte, Nothing)], [(SExtType (Base Single), Nothing)]]34 v = TypeDef (UserIdent "un9") Nothing (AUnion f)35 in parse "type :un9 = { { b } { s } }" @?= Right v,36 testCase "Union type with multiple nested fields" $37 let f =38 [ [(SExtType (Base Long), Nothing), (SExtType (Base Single), Nothing)],39 [(SExtType (Base Word), Nothing), (SExtType (Base Long), Nothing)]40 ]41 v = TypeDef (UserIdent "un9") Nothing (AUnion f)42 in parse "type :un9 = { { l, s } { w, l } }" @?= Right v43 ]44 where45 parse :: String -> Either P.ParseError TypeDef46 parse = P.parse typeDef ""4748dataTests :: TestTree49dataTests =50 testGroup51 "Data Definition"52 [ testCase "Data definition with zero fill" $53 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]54 in parse "data $foo = { z 42 }" @?= Right v,55 testCase "Data definition with empty value" $56 let v = DataDef [] (GlobalIdent "foo") Nothing []57 in parse "data $foo = {}" @?= Right v,58 testCase "Data definition without optional spaces" $59 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]60 in parse "data $foo={z 42}" @?= Right v,61 testCase "Data definition with newlines as spaces" $62 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]63 in parse "data\n$foo={z\n42}" @?= Right v,64 testCase "Data definition with comments" $65 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]66 in parse "data\n#test\n$foo={z\n#foo\n42}" @?= Right v,67 testCase "Data definition with comments and whitespaces" $68 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]69 in parse "data\n#test1 \n #test2\n$foo={z\n#foo\n42}" @?= Right v,70 testCase "Data definition with linkage" $71 let v = DataDef [LExport] (GlobalIdent "foo") Nothing [OZeroFill 42]72 in parse "export data $foo = { z 42 }" @?= Right v,73 testCase "Data definition with linkage, newlines, and comments" $74 let v = DataDef [LExport, LThread] (GlobalIdent "foo") Nothing [OZeroFill 42]75 in parse "export\nthread\n#foo\ndata $foo = { z 42 }" @?= Right v,76 testCase "Data definition with types" $77 let w = [DConst (Number 23), DConst (Number 42)]78 v = DataDef [] (GlobalIdent "bar") Nothing [OItem (Base Word) w]79 in parse "data $bar = { w 23 42 }" @?= Right v,80 testCase "An object containing two 64-bit fields" $81 let o =82 [ OItem (Base Long) [DConst (Number 0xffffffffffffffff)],83 OItem (Base Long) [DConst (Number 23)]84 ]85 v = DataDef [] (GlobalIdent "c") Nothing o86 in parse "data $c = { l -1, l 23 }" @?= Right v,87 testCase "Data definition with specified alignment and linkage" $88 let v = DataDef [LExport] (GlobalIdent "b") (Just AlignLong) [OZeroFill 1000]89 in parse "export data $b = align 8 { z 1000 }" @?= Right v,90 testCase "Data definition with linkage section and string escape sequences" $91 let v = DataDef [LSection "f\\oo\\\"bar" Nothing] (GlobalIdent "b") (Just AlignLong) [OZeroFill 1]92 in parse "section \"f\\oo\\\"bar\" data $b =align 8 {z 1}" @?= Right v93 ]94 where95 parse :: String -> Either P.ParseError DataDef96 parse = P.parse dataDef ""9798funcTests :: TestTree99funcTests =100 testGroup101 "Function Definition"102 [ testCase "Minimal function definition" $103 let p = [Regular (ABase Word) (LocalIdent "argc")]104 b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]105 f = FuncDef [] (GlobalIdent "main") Nothing p b106 in parse "function $main(w %argc) {\n@start\nret\n}" @?= Right f,107 testCase "Function definition with load instruction" $108 let s = [Assign (LocalIdent "v") Word (Load (LBase Word) (VLocal $ LocalIdent "addr"))]109 b = [Block {label = BlockIdent "begin", phi = [], stmt = s, term = Return Nothing}]110 f = FuncDef [] (GlobalIdent "main") Nothing [] b111 in parse "function $main() {\n@begin\n%v =w loadw %addr\nret\n}" @?= Right f,112 testCase "Function definition with linkage and return type" $113 let p = [Regular (ABase Long) (LocalIdent "v")]114 b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]115 f = FuncDef [LExport, LThread] (GlobalIdent "example") (Just (ABase Word)) p b116 in parse "export\nthread function w $example(l %v) {\n@start\nret\n}" @?= Right f,117 testCase "Function definition with section linkage" $118 let p = [Regular (ABase Long) (LocalIdent "v")]119 b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]120 f = FuncDef [LSection "foo" Nothing] (GlobalIdent "bla") (Just (ABase Word)) p b121 in parse "section \"foo\"\nfunction w $bla(l %v) {\n@start\nret\n}" @?= Right f,122 testCase "Function definition with subword return type" $123 let b = [Block {label = BlockIdent "here", phi = [], stmt = [], term = Halt}]124 f = FuncDef [] (GlobalIdent "f") (Just (ASubWordType SignedHalf)) [] b125 in parse "function sh $f() {\n@here\nhlt\n}" @?= Right f,126 testCase "Function definition with comments" $127 let p = [Regular (ABase Long) (LocalIdent "v")]128 b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]129 f = FuncDef [LSection "foo" (Just "bar")] (GlobalIdent "bla") (Just (ABase Word)) p b130 in parse "section \"foo\" \"bar\"\n#test\nfunction w $bla(l %v) {\n#foo\n@start\n# bar \nret\n#bllubbb\n#bllaaa\n}" @?= Right f,131 testCase "Function definition with comparison instruction" $132 let c = Compare Word CSlt (VConst (Const (Number 23))) (VConst (Const (Number 42)))133 b = [Block {label = BlockIdent "start", phi = [], stmt = [Assign (LocalIdent "res") Word c], term = Return Nothing}]134 f = FuncDef [] (GlobalIdent "f") Nothing [] b135 in parse "function $f() {\n@start\n%res =w csltw 23, 42\nret\n}" @?= Right f,136 testCase "Function definition with extend instruction" $137 let c = Ext SLSignedWord (VConst (Const (Number 42)))138 b = [Block {label = BlockIdent "start", phi = [], stmt = [Assign (LocalIdent "res") Word c], term = Return Nothing}]139 f = FuncDef [] (GlobalIdent "f") Nothing [] b140 in parse "function $f() {\n@start\n%res =w extsw 42\nret\n}" @?= Right f,141 testCase "Function definition with fallthrough block" $142 let b1 = Block {label = BlockIdent "b1", phi = [], stmt = [], term = Jump (BlockIdent "b2")}143 b2 = Block {label = BlockIdent "b2", phi = [], stmt = [], term = Return Nothing}144 f = FuncDef [] (GlobalIdent "f") Nothing [] [b1, b2]145 in parse "function $f() {\n@b1\n@b2\nret\n}" @?= Right f,146 testCase "Block with phi instrunction" $147 let v1 = VConst (Const (Number 1))148 v2 = VConst (Const (Number 2))149 p1 = Phi (LocalIdent "v") Word $ Map.fromList [(BlockIdent "b1", v1), (BlockIdent "b2", v2)]150 b1 = Block {label = BlockIdent "b1", phi = [], stmt = [], term = Jump (BlockIdent "b2")}151 b2 = Block {label = BlockIdent "b2", phi = [], stmt = [], term = Jump (BlockIdent "b3")}152 b3 = Block {label = BlockIdent "b3", phi = [p1], stmt = [], term = Return Nothing}153 fn = FuncDef [] (GlobalIdent "f") Nothing [] [b1, b2, b3]154 in parse "function $f() {\n@b1\njmp @b2\n@b2\njmp @b3\n@b3\n%v =w phi @b1 1, @b2 2\nret\n}" @?= Right fn,155 testCase "Call instruction with integer literal value" $156 let c = Call Nothing (VConst $ (Const $ Global (GlobalIdent "foo"))) [ArgReg (ABase Word) (VConst (Const (Number 42)))]157 b = [Block {label = BlockIdent "s", phi = [], stmt = [c], term = Return Nothing}]158 f = FuncDef [] (GlobalIdent "f") Nothing [] b159 in parse "function $f() {\n@s\ncall $foo(w 42)\nret\n}" @?= Right f160 ]161 where162 parse :: String -> Either P.ParseError FuncDef163 parse = P.parse funcDef ""164165mkParser :: TestTree166mkParser =167 testGroup168 "Tests for the QBE parser"169 [typeTests, dataTests, funcTests]