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 16) (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 v,43 testCase "Type definition with trailing comma" $44 let f = [(SExtType (Base Single), Nothing), (SExtType (Base Single), Nothing)]45 v = TypeDef (UserIdent "twofloats") Nothing (ARegular f)46 in parse "type :twofloats = { s, s, }" @?= Right v47 ]48 where49 parse :: String -> Either P.ParseError TypeDef50 parse = P.parse typeDef ""5152dataTests :: TestTree53dataTests =54 testGroup55 "Data Definition"56 [ testCase "Data definition with zero fill" $57 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]58 in parse "data $foo = { z 42 }" @?= Right v,59 testCase "Data definition with empty value" $60 let v = DataDef [] (GlobalIdent "foo") Nothing []61 in parse "data $foo = {}" @?= Right v,62 testCase "Data definition without optional spaces" $63 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]64 in parse "data $foo={z 42}" @?= Right v,65 testCase "Data definition with newlines as spaces" $66 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]67 in parse "data\n$foo={z\n42}" @?= Right v,68 testCase "Data definition with comments" $69 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]70 in parse "data\n#test\n$foo={z\n#foo\n42}" @?= Right v,71 testCase "Data definition with comments and whitespaces" $72 let v = DataDef [] (GlobalIdent "foo") Nothing [OZeroFill 42]73 in parse "data\n#test1 \n #test2\n$foo={z\n#foo\n42}" @?= Right v,74 testCase "Data definition with linkage" $75 let v = DataDef [LExport] (GlobalIdent "foo") Nothing [OZeroFill 42]76 in parse "export data $foo = { z 42 }" @?= Right v,77 testCase "Data definition with linkage, newlines, and comments" $78 let v = DataDef [LExport, LThread] (GlobalIdent "foo") Nothing [OZeroFill 42]79 in parse "export\nthread\n#foo\ndata $foo = { z 42 }" @?= Right v,80 testCase "Data definition with types" $81 let w = [DConst (Number 23), DConst (Number 42)]82 v = DataDef [] (GlobalIdent "bar") Nothing [OItem (Base Word) w]83 in parse "data $bar = { w 23 42 }" @?= Right v,84 testCase "An object containing two 64-bit fields" $85 let o =86 [ OItem (Base Long) [DConst (Number 0xffffffffffffffff)],87 OItem (Base Long) [DConst (Number 23)]88 ]89 v = DataDef [] (GlobalIdent "c") Nothing o90 in parse "data $c = { l -1, l 23 }" @?= Right v,91 testCase "Data definition with specified alignment and linkage" $92 let v = DataDef [LExport] (GlobalIdent "b") (Just 8) [OZeroFill 1000]93 in parse "export data $b = align 8 { z 1000 }" @?= Right v,94 testCase "Data definition with linkage section and string escape sequences" $95 let v = DataDef [LSection "f\\oo\\\"bar" Nothing] (GlobalIdent "b") (Just 8) [OZeroFill 1]96 in parse "section \"f\\oo\\\"bar\" data $b =align 8 {z 1}" @?= Right v,97 testCase "Data definition with symbol offset" $98 let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 8, objs = [OItem (Base Long) [DSymOff (GlobalIdent "s") 1]]}99 in parse "data $b = align 8 { l $s + 1 }" @?= Right v,100 testCase "Data definition with symbol offset and without whitespaces" $101 let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 8, objs = [OItem (Base Long) [DSymOff (GlobalIdent "s") 1]]}102 in parse "data $b = align 8 {l $s+1}" @?= Right v,103 testCase "Data definition with symbol but without offset" $104 let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 8, objs = [OItem (Base Long) [DConst (Global (GlobalIdent "s"))]]}105 in parse "data $b = align 8 {l $s}" @?= Right v,106 testCase "Data definition with octal character sequence" $107 let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 1, objs = [OItem Byte [DString "f\too\NUL"]]}108 in parse "data $b = align 1 { b \"f\\011oo\\000\" }" @?= Right v,109 testCase "Data definition with trailing comma" $110 let v = DataDef {linkage = [], name = GlobalIdent "b", align = Just 1, objs = [OItem Byte [DConst (Number 1)], OItem Byte [DConst (Number 2)]]}111 in parse "data $b = align 1 { b 1, b 2,}" @?= Right v112 ]113 where114 parse :: String -> Either P.ParseError DataDef115 parse = P.parse dataDef ""116117funcTests :: TestTree118funcTests =119 testGroup120 "Function Definition"121 [ testCase "Minimal function definition" $122 let p = [Regular (ABase Word) (LocalIdent "argc")]123 b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]124 f = FuncDef [] (GlobalIdent "main") Nothing p b125 in parse "function $main(w %argc) {\n@start\nret\n}" @?= Right f,126 testCase "Function definition with load instruction" $127 let s = [Assign (LocalIdent "v") Word (Load (LBase Word) (VLocal $ LocalIdent "addr"))]128 b = [Block {label = BlockIdent "begin", phi = [], stmt = s, term = Return Nothing}]129 f = FuncDef [] (GlobalIdent "main") Nothing [] b130 in parse "function $main() {\n@begin\n%v =w loadw %addr\nret\n}" @?= Right f,131 testCase "Function definition with linkage and return type" $132 let p = [Regular (ABase Long) (LocalIdent "v")]133 b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]134 f = FuncDef [LExport, LThread] (GlobalIdent "example") (Just (ABase Word)) p b135 in parse "export\nthread function w $example(l %v) {\n@start\nret\n}" @?= Right f,136 testCase "Function definition with section linkage" $137 let p = [Regular (ABase Long) (LocalIdent "v")]138 b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]139 f = FuncDef [LSection "foo" Nothing] (GlobalIdent "bla") (Just (ABase Word)) p b140 in parse "section \"foo\"\nfunction w $bla(l %v) {\n@start\nret\n}" @?= Right f,141 testCase "Function definition with subword return type" $142 let b = [Block {label = BlockIdent "here", phi = [], stmt = [], term = Halt}]143 f = FuncDef [] (GlobalIdent "f") (Just (ASubWordType SignedHalf)) [] b144 in parse "function sh $f() {\n@here\nhlt\n}" @?= Right f,145 testCase "Function definition with comments" $146 let p = [Regular (ABase Long) (LocalIdent "v")]147 b = [Block {label = BlockIdent "start", phi = [], stmt = [], term = Return Nothing}]148 f = FuncDef [LSection "foo" (Just "bar")] (GlobalIdent "bla") (Just (ABase Word)) p b149 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,150 testCase "Function definition with comparison instruction" $151 let c = Compare Word CSlt (VConst (Const (Number 23))) (VConst (Const (Number 42)))152 b = [Block {label = BlockIdent "start", phi = [], stmt = [Assign (LocalIdent "res") Word c], term = Return Nothing}]153 f = FuncDef [] (GlobalIdent "f") Nothing [] b154 in parse "function $f() {\n@start\n%res =w csltw 23, 42\nret\n}" @?= Right f,155 testCase "Function definition with extend instruction" $156 let c = Ext SLSignedWord (VConst (Const (Number 42)))157 b = [Block {label = BlockIdent "start", phi = [], stmt = [Assign (LocalIdent "res") Word c], term = Return Nothing}]158 f = FuncDef [] (GlobalIdent "f") Nothing [] b159 in parse "function $f() {\n@start\n%res =w extsw 42\nret\n}" @?= Right f,160 testCase "Function definition with fallthrough block" $161 let b1 = Block {label = BlockIdent "b1", phi = [], stmt = [], term = Jump (BlockIdent "b2")}162 b2 = Block {label = BlockIdent "b2", phi = [], stmt = [], term = Return Nothing}163 f = FuncDef [] (GlobalIdent "f") Nothing [] [b1, b2]164 in parse "function $f() {\n@b1\n@b2\nret\n}" @?= Right f,165 testCase "Block with phi instrunction" $166 let v1 = VConst (Const (Number 1))167 v2 = VConst (Const (Number 2))168 p1 = Phi (LocalIdent "v") Word $ Map.fromList [(BlockIdent "b1", v1), (BlockIdent "b2", v2)]169 b1 = Block {label = BlockIdent "b1", phi = [], stmt = [], term = Jump (BlockIdent "b2")}170 b2 = Block {label = BlockIdent "b2", phi = [], stmt = [], term = Jump (BlockIdent "b3")}171 b3 = Block {label = BlockIdent "b3", phi = [p1], stmt = [], term = Return Nothing}172 fn = FuncDef [] (GlobalIdent "f") Nothing [] [b1, b2, b3]173 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,174 testCase "Call instruction with integer literal value" $175 let c = Call Nothing (VConst (Const $ Global (GlobalIdent "foo"))) [ArgReg (ABase Word) (VConst (Const (Number 42)))]176 b = [Block {label = BlockIdent "s", phi = [], stmt = [c], term = Return Nothing}]177 f = FuncDef [] (GlobalIdent "f") Nothing [] b178 in parse "function $f() {\n@s\ncall $foo(w 42)\nret\n}" @?= Right f,179 testCase "Unary neg instruction" $180 let i1 = Assign (LocalIdent "r") Word $ Neg (VConst (Const (Number 1)))181 i2 = Assign (LocalIdent "r") Word $ Neg (VLocal $ LocalIdent "r")182 b = Block {label = BlockIdent "s", phi = [], stmt = [i1, i2], term = Halt}183 f = FuncDef [] (GlobalIdent "f") Nothing [] [b]184 in parse "function $f() {\n@s\n%r =w neg 1\n%r =w neg %r\nhlt\n}" @?= Right f,185 testCase "cast instruction" $186 let c = Assign (LocalIdent "r") Word $ Cast (VLocal $ LocalIdent "f")187 b = Block {label = BlockIdent "s", phi = [], stmt = [c], term = Halt}188 f = FuncDef [] (GlobalIdent "f") Nothing [Regular (ABase Single) (LocalIdent "f")] [b]189 in parse "function $f(s %f) {\n@s\n%r =w cast %f\nhlt\n}" @?= Right f190 ]191 where192 parse :: String -> Either P.ParseError FuncDef193 parse = P.parse funcDef ""194195mkParser :: TestTree196mkParser =197 testGroup198 "Tests for the QBE parser"199 [typeTests, dataTests, funcTests]